Forum |  HardWare.fr | News | Articles | PC | S'identifier | S'inscrire | Shop Recherche
1528 connectés 

 
 


 Mot :   Pseudo :  
 
 Page :   1  2  3  4  5  6  7
Page Suivante
Page Précédente
Bas de page 
Auteur Sujet :

[Résolu] Export données en perl

n°2223899
gilou
Modérateur
Modzilla
Posté le 02-04-2014 à 16:12:16  profilanswer
 

Reprise du message précédent :
Ah ben j'allais justement te le dire: tu avais fait la mauvaise conversion hexa <--> décimal pour l'adresse, mais tu t'en es aperçu.
 
Comme perl comprends directement les nombres en hexadecimal, tu aurais aussi pu faire:
my @adresses = (265, ...);  (sans qw devant, mais liste séparée par des virgules)
ou
my @adresses = (0x0109, ...); (surtout sans quotes autour, ni qw pour que ça soit pas pris pour une chaine de texte)
 
 
A+,


Message édité par gilou le 02-04-2014 à 16:12:34

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
mood
Publicité
Posté le 02-04-2014 à 16:12:16  profilanswer
 

n°2223902
clubber43
Posté le 02-04-2014 à 16:28:17  profilanswer
 

OK,  
je continue tant que c'est encore chaud dans ma tête!
 
Merci pour le coup de main, ça commence à rentrer ^^
 
@+

n°2223928
gilou
Modérateur
Modzilla
Posté le 02-04-2014 à 18:57:39  profilanswer
 

En mettant tout cela un peu plus au propre, ça devrait donner qque chose comme:

Code :
  1. #!/usr/bin/perl
  2. use strict;
  3. use warnings;
  4. use Socket;
  5.  
  6.  
  7. # Paramètres ModBus/TCP
  8. my $MODBUS_PORT                                 = 502;
  9. use constant {
  10.   # Codes des fonctions lecture, ecriture, ...
  11.   READ_COILS                                    => 0x01,
  12.   READ_DISCRETE_INPUTS                          => 0x02,
  13.   READ_HOLDING_REGISTERS                        => 0x03,
  14.   READ_INPUT_REGISTERS                          => 0x04,
  15.   WRITE_SINGLE_COIL                             => 0x05,
  16.   WRITE_SINGLE_REGISTER                         => 0x06,
  17.   # Codes des exceptions erreurs, ...
  18.   EXP_ILLEGAL_FUNCTION                          => 0x01,
  19.   EXP_DATA_ADDRESS                              => 0x02,
  20.   EXP_DATA_VALUE                                => 0x03,
  21.   EXP_SLAVE_DEVICE_FAILURE                      => 0x04,
  22.   EXP_ACKNOWLEDGE                               => 0x05,
  23.   EXP_SLAVE_DEVICE_BUSY                         => 0x06,
  24.   EXP_MEMORY_PARITY_ERROR                       => 0x08,
  25.   EXP_GATEWAY_PATH_UNAVAILABLE                  => 0x0A,
  26.   EXP_GATEWAY_TARGET_DEVICE_FAILED_TO_RESPOND   => 0x0B,
  27. };
  28.  
  29. # Valeurs par défaut
  30. my $opt_server                                  = 'localhost';
  31. my $opt_server_port                             = $MODBUS_PORT; #502
  32. my $opt_timeout                                 = 1; # temps max de 1 s
  33. my $opt_unit_id                                 = 1;
  34. my $opt_mb_ad;
  35. my $opt_mb_fc                                   = READ_HOLDING_REGISTERS;
  36. my $opt_mb_nb                                   = 1;
  37. my $opt_bit_value                               = 0;
  38. my $opt_word_value                              = 0;
  39.  
  40.  
  41. $opt_server = '172.17.14.3';          # @ IP du serveur TCP
  42. my $server_ip = inet_aton($opt_server);      # on donne l'@ IP à la variable
  43. unless ($server_ip) { 
  44.   print STDERR 'unable to resolve "'.$opt_server.'"'."\n"; # et la, 
  45.   exit 1; 
  46. }
  47.  
  48. my $status = query_info();
  49. until ($status) {
  50.   sleep(10);             # toutes les 10s, a adapter à ses besoins
  51.   $status = query_info();
  52. }
  53. # boucle infinie, a stopper avec un kill
  54. sub query_info{
  55.   # Gestion du dialogue reseau
  56.   # Ouverture de la session TCP
  57.   socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
  58.   unless (connect(SERVER, sockaddr_in($MODBUS_PORT, $server_ip))) {
  59.     print STDERR 'connexion au serveur "'.$server_ip.':'.$MODBUS_PORT.'" impossible'."\n";
  60.     return 2;
  61.   }
  62.  
  63.   my %parametres;
  64.   # courant
  65.   $parametres{"COURANT_1"} = {address => 0x0E, size => 2, signed => 1};
  66.   $parametres{"COURANT_2"} = {address => 0x10, size => 2, signed => 1};
  67.   $parametres{"COURANT_3"} = {address => 0x12, size => 2, signed => 1};
  68.   $parametres{"COURANT_M"} = {address => 0x16, size => 2, signed => 1};
  69.   # phase
  70.   $parametres{"DEPHASAGE_1"} = {address => 0x18, size => 1, signed => 1};
  71.   $parametres{"DEPHASAGE_2"} = {address => 0x19, size => 1, signed => 1};
  72.   $parametres{"DEPHASAGE_3"} = {address => 0x1A, size => 1, signed => 1};
  73.   $parametres{"DEPHASAGE_M"} = {address => 0x1B, size => 1, signed => 1};
  74.   # puissance
  75.   $parametres{"PUISSANCE"} = {address => 0x109, size => 3, signed => 0};
  76.   # etc
  77.   my %result;
  78.   foreach (sort {$a cmp $b} (keys %parametres)) {
  79.     $opt_mb_ad = $parametres{$_}->{address};
  80.     $opt_mb_nb = $parametres{$_}->{size};
  81.     # Création de la requête 
  82.     my $tx_hd_tr_id   = int(rand 65536);
  83.     my $tx_hd_length  = 6;
  84.     my $tx_hd_pr_id   = 0;
  85.     my $tx_buffer = pack("nnnCCnn", $tx_hd_tr_id, $tx_hd_pr_id , $tx_hd_length, $opt_unit_id, $opt_mb_fc, $opt_mb_ad, $opt_mb_nb);
  86.  
  87.     # Emission de la requête vers le serveur
  88.     send(SERVER, $tx_buffer, 0);
  89.  
  90.     # Attente d'une réponse
  91.     unless (can_read('SERVER', $opt_timeout)) {
  92.       close SERVER;
  93.       print STDERR 'receive timeout'."\n"; # erreur si depassement du temps d'attente
  94.       return 1;
  95.     }
  96.  
  97.     # Réception de l'entête depuis le serveur
  98.     my ($rx_frame, $rx_buffer);
  99.     recv(SERVER, $rx_buffer, 7, 0);
  100.     $rx_frame = $rx_buffer;
  101.  
  102.     # Décodage de l'entête
  103.     my ($rx_hd_tr_id, $rx_hd_pr_id, $rx_hd_length, $rx_hd_unit_id) = unpack "nnnC", $rx_buffer;
  104.  
  105.     # Vérifie la cohérence de l'entête
  106.     unless (($rx_hd_tr_id == $tx_hd_tr_id) &&
  107.         ($rx_hd_pr_id == 0) &&
  108.         ($rx_hd_length < 256) &&
  109.         ($rx_hd_unit_id == 1)) {
  110.       close SERVER;
  111.       print STDERR 'error in receive frame'."\n";
  112.       return 1;
  113.     }
  114.  
  115.     # Réception du corps du message
  116.     recv(SERVER, $rx_buffer, $rx_hd_length-1, 0);
  117.     $rx_frame .= $rx_buffer;
  118.  
  119.  
  120.     # Décodage du corps du message
  121.     my ($rx_bd_fc, $rx_body) = unpack "Ca*", $rx_buffer;
  122.  
  123.     # Vérification du statut d'exception
  124.     if ($rx_bd_fc > 0x80) {
  125.       # Affichage du code exception
  126.       my ($rx_except_code) = unpack "C", $rx_body;
  127.       print 'exception (code '.$rx_except_code.')'."\n";
  128.     } else {
  129.       ## Lecture de mot
  130.       my ($rx_bd_bc, $rx_read_word_data) = unpack "Ca*", $rx_body;
  131.       my ($val1, $val2, $val3);
  132.       if ($opt_mb_nb == 1) {
  133.     $result{$opt_mb_ad} = unpack 'n', $rx_read_word_data;
  134.     if (($parametres{$_}->{signed} == 1) and ($result{$opt_mb_ad} >= 2**15)) {
  135.       $result{$opt_mb_ad} -= 2**16;
  136.     }
  137.       }
  138.       elsif ($opt_mb_nb == 2) {
  139.     ($val1, $val2) = unpack 'nn', $rx_read_word_data;
  140.     $result{$opt_mb_ad} = $val2 * (2**16) + $val1;
  141.     if (($parametres{$_}->{signed} == 1) and ($result{$opt_mb_ad} >= 2**31)) {
  142.       $result{$opt_mb_ad} -= 2**32;
  143.     }
  144.       }
  145.       elsif ($opt_mb_nb == 3) {
  146.     ($val1, $val2, $val3) = unpack 'nnn', $rx_read_word_data;
  147.     $result{$opt_mb_ad} = $val3 * (2**32) + $val2 * (2**16) + $val1;
  148.     if (($parametres{$_}->{signed} == 1) and ($result{$opt_mb_ad} >= 2**47)) {
  149.       $result{$opt_mb_ad} -= 2**48;
  150.     }
  151.       }
  152.     }
  153.   }
  154.   close SERVER;
  155.   # fin de la boucle foreach 
  156.   # impression en console
  157.   foreach (sort {$a <=> $b} (keys %result)) {
  158.     print "\n<$_> : $result{$_} ;\n" # On utilise un hash pour passer les valeurs et avoir plusieurs valeurs par retour
  159.   }
  160.   print "\n";
  161.   #attente $timeout
  162.   sub can_read{
  163.     my ($sock_handle, $timeout) = @_;
  164.     my $hdl_select="";
  165.     vec($hdl_select, fileno($sock_handle),1)=1;
  166.     return (select($hdl_select, undef, undef, $timeout)==1);
  167.   }
  168.   my $time = time; 
  169.   my @months = ("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec" );
  170.   my ($sec, $min, $hour, $day,$month,$year) = (localtime($time))[0,1,2,3,4,5];
  171.   print "timestamp : ".$time. " \n";
  172. }


La syntaxe est bonne, mais bien sur, j'ai pas pu tester en vraie grandeur
A+,


Message édité par gilou le 03-04-2014 à 11:51:55

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2223978
clubber43
Posté le 03-04-2014 à 08:57:37  profilanswer
 

Le code est génial, bien fai et ordonné ^^
J'ai essayé de faire un peu pareil, mais c'était, comment die, le foutoir  :)  
 
Merci pour l'aide Gilou, là, je suis bien pour avancer mon projet;
 
Aujourd'hui, j'essaie de finir de commprendre le script; mais il est bien stucturé donc facile à comprenre je pense
Et puis je posterais les resultats de ma phase 2 du projet, à savoir la mise en BDD des valeurs exportées depuis le module Ethernet.
 
Merci encore.
 
@+

n°2223997
clubber43
Posté le 03-04-2014 à 10:23:18  profilanswer
 

Bon,  
Certain vont me trouver pénible,  
 
J'ai bien tout compris dans le code, la compile marche, les données exportées sont les bonnnes, mais je ne comprend pas pourquoi, la boucle de Query_Infos ne fonctionne pas.
Elle est appelée dans le programme grace à [b]sub query_info {[/b] me semble-t-il ?  
 
Enfin, derniere épine, quand j'écris les adresses IP dans mon fichier txt, le script me renvoie connexion impossible #502
J'ai l'impression que la boucle de recherche des variables ne se lance pas, ou alors que les adresses ne se lisent pas correctement.
 

Code :
  1. #!/usr/bin/perl
  2. use strict;
  3. use warnings;
  4. use Socket;
  7. # Paramètres ModBus/TCP
  8. my $MODBUS_PORT                                 = 502;
  9. use constant {
  10.   # Codes des fonctions lecture, ecriture, ...
  11.   READ_COILS                                    => 0x01,
  12.   READ_DISCRETE_INPUTS                          => 0x02,
  13.   READ_HOLDING_REGISTERS                        => 0x03,
  14.   READ_INPUT_REGISTERS                          => 0x04,
  15.   WRITE_SINGLE_COIL                             => 0x05,
  16.   WRITE_SINGLE_REGISTER                         => 0x06,
  17.   # Codes des exceptions erreurs, ...
  18.   EXP_ILLEGAL_FUNCTION                          => 0x01,
  19.   EXP_DATA_ADDRESS                              => 0x02,
  20.   EXP_DATA_VALUE                                => 0x03,
  21.   EXP_SLAVE_DEVICE_FAILURE                      => 0x04,
  22.   EXP_ACKNOWLEDGE                               => 0x05,
  23.   EXP_SLAVE_DEVICE_BUSY                         => 0x06,
  24.   EXP_MEMORY_PARITY_ERROR                       => 0x08,
  25.   EXP_GATEWAY_PATH_UNAVAILABLE                  => 0x0A,
  26.   EXP_GATEWAY_TARGET_DEVICE_FAILED_TO_RESPOND   => 0x0B,
  27. };
  29. # Valeurs par défaut
  30. my $opt_server                                  = 'localhost';
  31. my $opt_server_port                             = $MODBUS_PORT; #502 par defaut
  32. my $opt_timeout                                 = 1; # temps max de 1 s
  33. my $opt_unit_id                                 = 1;
  34. my $opt_mb_ad;
  35. my $opt_mb_fc                                   = READ_HOLDING_REGISTERS;
  36. my $opt_mb_nb                                   = 1;
  37. my $opt_bit_value                               = 0;
  38. my $opt_word_value                              = 0;
  39. my $adresse                                     = 0;
  40. my $ligne                                       = 0;
  43. open(F,'c:/adresses_ip.txt') || die "impossible ";
  45. # debut de la boucle ligne à ligne sur le fichier
  46.   while (<F> ) {
  48. # récupération des éléments
  49.   ($adresse) = split /;/,$ligne;
  51. # on insere dans le script
  52.   $opt_server = $adresse;
  54. # on donne l'@ IP à la variable
  55.   my $server_ip = inet_aton($opt_server);                 
  56.   unless ($server_ip) {
  57.     print STDERR 'unable to resolve "'.$opt_server.'"'."\n";
  58.     exit 1;
  59.   }
  60. # la fonction est appelée, mais ne marche pas, le script s'arrete après la premiere boucle.
  61.  my $status = query_info();
  62.   until ($status) {
  63.   sleep(5);                   
  64. # toutes les 5s, a adapter aux besoins
  66.   $status = query_info();
  67.   }
  72. sub query_info {
  73.   # Gestion du dialogue reseau
  74.   # Ouverture de la session TCP
  75.   socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
  76.   unless (connect(SERVER, sockaddr_in($MODBUS_PORT, $server_ip))) {
  77.     print STDERR 'connexion au serveur "'.$server_ip.':'.$MODBUS_PORT.'" impossible'."\n";
  78.     return 2;
  79.   }
  81.   my %parametres;
  83. # déphasage
  85.   $parametres{"DEPHASAGE_1"} = {address => 0x18, size => 1, signed => 1};
  86.   $parametres{"DEPHASAGE_2"} = {address => 0x19, size => 1, signed => 1};
  87.   $parametres{"DEPHASAGE_3"} = {address => 0x1A, size => 1, signed => 1};
  88.   $parametres{"DEPHASAGE_M"} = {address => 0x1B, size => 1, signed => 1};
  89.  
  90. # puissance
  91.   $parametres{"PUISSANCE"} = {address => 0x109, size => 3, signed => 0};
  92.   $parametres{"BALANCE"} = {address => 0x41E, size => 3, signed => 0};
  94.   my %result;
  95. # On passe en parametres les adresses en Hexa et la tailel de la variable (mots, signe)
  96.   foreach (sort {$a cmp $b} (keys %parametres)) {
  97.     $opt_mb_ad = $parametres{$_}->{address};
  98.     $opt_mb_nb = $parametres{$_}->{size};
  100.     # Création de la requête
  101.     my $tx_hd_tr_id   = int(rand 65536);
  102.     my $tx_hd_length  = 6;
  103.     my $tx_hd_pr_id   = 0;
  104.     my $tx_buffer = pack("nnnCCnn", $tx_hd_tr_id, $tx_hd_pr_id , $tx_hd_length, $opt_unit_id, $opt_mb_fc, $opt_mb_ad, $opt_mb_nb);
  106.     # Emission de la requête vers le serveur
  107.     send(SERVER, $tx_buffer, 0);
  109.     # Attente d'une réponse
  110.     unless (can_read('SERVER', $opt_timeout)) {
  111.       close SERVER;
  112.       print STDERR 'receive timeout'."\n"; # erreur si depassement du temps d'attente
  113.       return 1;
  114.     }
  116.     # Réception de l'entête depuis le serveur
  117.     my ($rx_frame, $rx_buffer);
  118.     recv(SERVER, $rx_buffer, 7, 0);
  119.     $rx_frame = $rx_buffer;
  121.     # Décodage de l'entête
  122.     my ($rx_hd_tr_id, $rx_hd_pr_id, $rx_hd_length, $rx_hd_unit_id) = unpack "nnnC", $rx_buffer;
  124.     # Vérifie la cohérence de l'entête
  125.     unless (($rx_hd_tr_id == $tx_hd_tr_id) &&
  126.         ($rx_hd_pr_id == 0) &&
  127.         ($rx_hd_length < 256) &&
  128.         ($rx_hd_unit_id == 1)) {
  129.       close SERVER;
  130.       print STDERR 'error in receive frame'."\n";
  131.       return 1;
  132.     }
  134.     # Réception du corps du message
  135.     recv(SERVER, $rx_buffer, $rx_hd_length-1, 0);
  136.     $rx_frame .= $rx_buffer;
  139.     # Décodage du corps du message
  140.     my ($rx_bd_fc, $rx_body) = unpack "Ca*", $rx_buffer;
  142.     # Vérification du statut d'exception
  143.     if ($rx_bd_fc > 0x80) {
  145.       # Affichage du code exception
  146.       my ($rx_except_code) = unpack "C", $rx_body;
  147.       print 'exception (code '.$rx_except_code.')'."\n";
  148.     } else {
  150.       ## Lecture de mot
  151.       my ($rx_bd_bc, $rx_read_word_data) = unpack "Ca*", $rx_body;
  152.       my ($val1, $val2, $val3);
  154. # Si on a 1 mots :
  155.       if ($opt_mb_nb == 1) {
  156.     $result{$opt_mb_ad} = unpack 'n', $rx_read_word_data;
  157.       if ($parametres{$_}->{signed}) {
  158.       $result{$opt_mb_ad} -= 2**16;
  159.     }
  160.       }
  161. # Si on a 2 mots :
  162.       elsif ($opt_mb_nb == 2) {
  163.     ($val1, $val2) = unpack 'nn', $rx_read_word_data;
  164.     $result{$opt_mb_ad} = $val2 * (2**16) + $val1;
  165.     if ($parametres{$_}->{signed}) {
  166.       $result{$opt_mb_ad} -= 2**32;
  167.     }
  168.       }
  170. # Si on a 3 mots :
  171.       elsif ($opt_mb_nb == 3) {
  172.     ($val1, $val2, $val3) = unpack 'nnn', $rx_read_word_data;
  173.     $result{$opt_mb_ad} = $val3 * (2**32) + $val2 * (2**16) + $val1;
  174.     if ($parametres{$_}->{signed}) {
  175.       $result{$opt_mb_ad} -= 2**48;
  176.     }
  177.       }
  178.     }
  179.   }
  180.   close SERVER;
  181.   # fin de la boucle foreach
  183.   # impression en console
  184. foreach (sort {$a <=> $b} (keys %result)) {
  185.     print "\n<$_> : $result{$_} ;\n" # On utilise un hash pour passer les valeurs et avoir plusieurs valeurs par retour
  186.   }
  187.   print "\n";
  189. #attente $timeout
  190.   sub can_read{
  191.     my ($sock_handle, $timeout) = @_;
  192.     my $hdl_select="";
  193.     vec($hdl_select, fileno($sock_handle),1)=1;
  194.     return (select($hdl_select, undef, undef, $timeout)==1);
  195.   }
  197. #Impression de la date au format TimeStamp
  198.   my $time = time;
  199.   #my @months = ("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec" );
  200.   my ($sec, $min, $hour, $day,$month,$year) = (localtime($time))[0,1,2,3,4,5];
  201.   print "timestamp : ".$time. " \n";
  202. }
  204. }


 
Voilà;
je cherche els erreurs, et si j'avance, je reviendrais ici . .  
 
 
@ tte

n°2224000
clubber43
Posté le 03-04-2014 à 10:32:21  profilanswer
 

-> Reflex d'hier avec $val, quand je faits mon print $adresse après #récuperation des elements, la console me renvoie un 0.
Donc a priori, pb de lecture de l'adresse, je continue mais recherches.
 
@@

n°2224007
gilou
Modérateur
Modzilla
Posté le 03-04-2014 à 11:08:22  profilanswer
 

Clairement tout cela vient de ta manière de récuperer les infos dans adresses_ip.txt
Il a quelle tête ce fichier?
 
A+,


---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224014
gilou
Modérateur
Modzilla
Posté le 03-04-2014 à 11:49:46  profilanswer
 

Au fait, j'avais oublié d'ajouter la condition de changement de signe pour les valeurs signées, j'ai modifié mon code précédent:
Avant

Code :
  1. if ($parametres{$_}->{signed}) {
  2.       $result{$opt_mb_ad} -= 2**16;


Après

Code :
  1. if (($parametres{$_}->{signed} == 1) and ($result{$opt_mb_ad} >= 2**15)) {
  2.       $result{$opt_mb_ad} -= 2**16;


 
et pareil pour les deux autres cas de figure.
 
A+,


---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224022
clubber43
Posté le 03-04-2014 à 13:21:03  profilanswer
 

A ok pour les modif, c'est OK,  
 
Pour mon fichier d'adresses IP, j'ai un fichier.txt avec dedans,  
 

Code :
  1. 172.17.14.1;
  2. 172.17.14.2;
  3. 172.17.14.3;


 
Voilà;
 
@

n°2224029
gilou
Modérateur
Modzilla
Posté le 03-04-2014 à 14:05:25  profilanswer
 

Sauf que ça change toute la logique de la boucle d'avoir plusieurs IPs :/
Je vais jeter un oeil a un remaniement.
 
Bon, en attendant, je crains avoir trouvé un bug dans le source dont je suis parti
Pourrais tu remplacer (dans une version du programme avec une seule IP, qui marche)
 
# Attente d'une réponse
    unless (can_read('SERVER', $opt_timeout)) {
 
par
# Attente d'une réponse
    unless (can_read(SERVER, $opt_timeout)) {
 
sans les quotes autour de SERVER, et me dire si ça marche toujours?
 
A+,


Message édité par gilou le 03-04-2014 à 14:07:10

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
mood
Publicité
Posté le 03-04-2014 à 14:05:25  profilanswer
 

n°2224031
clubber43
Posté le 03-04-2014 à 14:08:36  profilanswer
 


Mauvaise nouvelle pour la modif,  
 
Sa ne fonctionne plus sans les ' ' => Bareword "SERVER" nt allowed while stricts sub in use.

n°2224085
clubber43
Posté le 04-04-2014 à 09:10:21  profilanswer
 

Qu'est-c que change le fait de changer : 'SERVER' ou SERVER dans le programme ?  
La cible est toujours la meme non ?

n°2224107
gilou
Modérateur
Modzilla
Posté le 04-04-2014 à 13:32:40  profilanswer
 

Non.  
Quand tu fais open(SERVER, ...
1) on crée en interne une structure de donnée (opaque) qu'on associe au fichier
2) on crée une variable *SERVER de type typeglob, qu'on associe à cette structure
3) le nom SERVER sans * devant est utilisé pour passer la variable *SERVER par référence dans les subroutines (et non par copie, comme c'est le cas avec le passage de variables à un sub en perl)  [seul cas de figure ou on a un vrai passage par référence en perl, en dehors des cas ou on passe par copie une variable dont la valeur est l'adresse d'une variable]
Tandis que 'SERVER' est juste une variable scalaire anonyme de valeur la chaine 'SERVER'.  
 
Donc j'ai l'impression que le test sur can_read est foireux.
 
Et si tu fais unless (can_read(\*SERVER, $opt_timeout)) {
...
 
ça donne quoi?
 
Bon, je réécrirais le code en style moderne, avec une vraie variable locale.
open(my $server,..
ici, $server est un scalaire dont la valeur au retour est l'adresse de la structure de donnée opaque associée au fichier
 
A+,


Message édité par gilou le 04-04-2014 à 13:38:37

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224111
clubber43
Posté le 04-04-2014 à 14:11:10  profilanswer
 

Ok, c'est un peu comme en C quand on utilise les pointeurs, passage en valeur/référence si j'ai bien suivi.
 
Pou la modif. avec

Code :
  1. (can_read(\*SERVER, $opt_timeout)) {


C'est ok, le code compile en renvoie le code de connexion impossble.
 
Voilà le code, tel qu'il est sur mon PC, j'ai juste rajouté quelques commentaires sur le script (pour le comprendre)
 

Code :
  1. #!/usr/bin/perl
  2. use strict;
  3. use warnings;
  4. use Socket;
  7. # Paramètres ModBus/TCP
  8. my $MODBUS_PORT                                 = 502;
  9. use constant {
  10.   # Codes des fonctions lecture, ecriture, ...
  11.   READ_COILS                                    => 0x01,
  12.   READ_DISCRETE_INPUTS                          => 0x02,
  13.   READ_HOLDING_REGISTERS                        => 0x03,
  14.   READ_INPUT_REGISTERS                          => 0x04,
  15.   WRITE_SINGLE_COIL                             => 0x05,
  16.   WRITE_SINGLE_REGISTER                         => 0x06,
  17.   # Codes des exceptions erreurs, ...
  18.   EXP_ILLEGAL_FUNCTION                          => 0x01,
  19.   EXP_DATA_ADDRESS                              => 0x02,
  20.   EXP_DATA_VALUE                                => 0x03,
  21.   EXP_SLAVE_DEVICE_FAILURE                      => 0x04,
  22.   EXP_ACKNOWLEDGE                               => 0x05,
  23.   EXP_SLAVE_DEVICE_BUSY                         => 0x06,
  24.   EXP_MEMORY_PARITY_ERROR                       => 0x08,
  25.   EXP_GATEWAY_PATH_UNAVAILABLE                  => 0x0A,
  26.   EXP_GATEWAY_TARGET_DEVICE_FAILED_TO_RESPOND   => 0x0B,
  27. };
  29. # Valeurs par défaut
  30. my $opt_server                                  = 'localhost';
  31. my $opt_server_port                             = $MODBUS_PORT; #502 par defaut
  32. my $opt_timeout                                 = 1; # temps max de 1 s
  33. my $opt_unit_id                                 = 1;
  34. my $opt_mb_ad;
  35. my $opt_mb_fc                                   = READ_HOLDING_REGISTERS;
  36. my $opt_mb_nb                                   = 1;
  37. my $opt_bit_value                               = 0;
  38. my $opt_word_value                              = 0;
  39. my $adresse                                     = 0;
  40. my $ligne                                       = 0;
  43. #Ouverture du fichier contenant les adresses IP des modules Ethernet
  44. open(F,'c:/adresses_ip.txt') || die "impossible d'ouvrir le fichier";
  46. # debut de la boucle ligne à ligne sur le fichier
  47.   while (<F> ) {
  49. # récupération des éléments
  50.   ($adresse) = split /;/,$ligne;
  51.   print"$adresse \n";
  53. # on insere dans le script
  54.   $opt_server = $adresse ;
  55.  
  57. # on donne l'@ IP à la variable
  58.   my $server_ip = inet_aton($opt_server);                 
  59.   unless ($server_ip) {
  60.     print STDERR 'unable to resolve "'.$opt_server.'"'."\n";
  61.     exit 1;
  62.   }
  64.   my $status = query_info();
  65.   until ($status) {
  66.   sleep(10);                   
  67. # toutes les 10s, a adapter à ses besoins
  69.   $status = query_info();
  70.   }
  76. sub query_info {
  77.   # Gestion du dialogue reseau
  78.   # Ouverture de la session TCP
  79.   socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
  80.   unless (connect(SERVER, sockaddr_in($MODBUS_PORT, $server_ip))) {
  81.     print STDERR 'connexion au serveur "'.$server_ip.':'.$MODBUS_PORT.'" impossible'."\n";
  82.     return 2;
  83.   }
  85.   my %parametres;
  87. # déphasage
  89.   $parametres{"DEPHASAGE_1"} = {address => 0x18, size => 1, signed => 1};
  90.   $parametres{"DEPHASAGE_2"} = {address => 0x19, size => 1, signed => 1};
  91.   $parametres{"DEPHASAGE_3"} = {address => 0x1A, size => 1, signed => 1};
  92.   $parametres{"DEPHASAGE_M"} = {address => 0x1B, size => 1, signed => 1};
  93.  
  94. # puissance
  95.   $parametres{"PUISSANCE"} = {address => 0x109, size => 3, signed => 0};
  96.   $parametres{"BALANCE"} = {address => 0x41E, size => 3, signed => 0};
  98.   my %result;
  99. # On passe en parametres les adresses en Hexa et la tailel de la variable (mots, signe)
  100.   foreach (sort {$a cmp $b} (keys %parametres)) {
  101.     $opt_mb_ad = $parametres{$_}->{address};
  102.     $opt_mb_nb = $parametres{$_}->{size};
  104.     # Création de la requête
  105.     my $tx_hd_tr_id   = int(rand 65536);
  106.     my $tx_hd_length  = 6;
  107.     my $tx_hd_pr_id   = 0;
  108.     my $tx_buffer = pack("nnnCCnn", $tx_hd_tr_id, $tx_hd_pr_id , $tx_hd_length, $opt_unit_id, $opt_mb_fc, $opt_mb_ad, $opt_mb_nb);
  110.     # Emission de la requête vers le serveur
  111.     send(SERVER, $tx_buffer, 0);
  113.     # Attente d'une réponse
  114.     unless (can_read(\*SERVER, $opt_timeout)) {
  115.       close SERVER;
  116.       print STDERR 'receive timeout'."\n"; # erreur si depassement du temps d'attente
  117.       return 1;
  118.     }
  120.     # Réception de l'entête depuis le serveur
  121.     my ($rx_frame, $rx_buffer);
  122.     recv(SERVER, $rx_buffer, 7, 0);
  123.     $rx_frame = $rx_buffer;
  125.     # Décodage de l'entête
  126.     my ($rx_hd_tr_id, $rx_hd_pr_id, $rx_hd_length, $rx_hd_unit_id) = unpack "nnnC", $rx_buffer;
  128.     # Vérifie la cohérence de l'entête
  129.     unless (($rx_hd_tr_id == $tx_hd_tr_id) &&
  130.         ($rx_hd_pr_id == 0) &&
  131.         ($rx_hd_length < 256) &&
  132.         ($rx_hd_unit_id == 1)) {
  133.       close SERVER;
  134.       print STDERR 'error in receive frame'."\n";
  135.       return 1;
  136.     }
  138.     # Réception du corps du message
  139.     recv(SERVER, $rx_buffer, $rx_hd_length-1, 0);
  140.     $rx_frame .= $rx_buffer;
  143.     # Décodage du corps du message
  144.     my ($rx_bd_fc, $rx_body) = unpack "Ca*", $rx_buffer;
  146.     # Vérification du statut d'exception
  147.     if ($rx_bd_fc > 0x80) {
  149.       # Affichage du code exception
  150.       my ($rx_except_code) = unpack "C", $rx_body;
  151.       print 'exception (code '.$rx_except_code.')'."\n";
  152.     } else {
  154.       ## Lecture de mot
  155.       my ($rx_bd_bc, $rx_read_word_data) = unpack "Ca*", $rx_body;
  156.       my ($val1, $val2, $val3);
  158. # Si on a 1 mots :
  159.       if ($opt_mb_nb == 1) {
  160.     $result{$opt_mb_ad} = unpack 'n', $rx_read_word_data;
  161.       if ($parametres{$_}->{signed}) {
  162.       $result{$opt_mb_ad} -= 2**16;
  163.     }
  164.       }
  165. # Si on a 2 mots :
  166.       elsif ($opt_mb_nb == 2) {
  167.     ($val1, $val2) = unpack 'nn', $rx_read_word_data;
  168.     $result{$opt_mb_ad} = $val2 * (2**16) + $val1;
  169.     if ($parametres{$_}->{signed}) {
  170.       $result{$opt_mb_ad} -= 2**32;
  171.     }
  172.       }
  174. # Si on a 3 mots :
  175.       elsif ($opt_mb_nb == 3) {
  176.     ($val1, $val2, $val3) = unpack 'nnn', $rx_read_word_data;
  177.     $result{$opt_mb_ad} = $val3 * (2**32) + $val2 * (2**16) + $val1;
  178.     if ($parametres{$_}->{signed}) {
  179.       $result{$opt_mb_ad} -= 2**48;
  180.     }
  181.       }
  182.     }
  183.   }
  184.   close SERVER;
  185.   # fin de la boucle foreach
  187.   # impression en console
  188. foreach (sort {$a <=> $b} (keys %result)) {
  189.     print "\n<$_> : $result{$_} ;\n" # On utilise un hash pour passer les valeurs et avoir plusieurs valeurs par retour
  190.   }
  191.   print "\n";
  193. #attente $timeout
  194.   sub can_read{
  195.     my ($sock_handle, $timeout) = @_;
  196.     my $hdl_select="";
  197.     vec($hdl_select, fileno($sock_handle),1)=1;
  198.     return (select($hdl_select, undef, undef, $timeout)==1);
  199.   }
  201. #Impression de la date au format TimeStamp
  202.   my $time = time;
  203.   #my @months = ("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec" );
  204.   my ($sec, $min, $hour, $day,$month,$year) = (localtime($time))[0,1,2,3,4,5];
  205.   print "timestamp : ".$time. " \n";
  206. }
  208. }


 
@+ et merci

Message cité 1 fois
n°2224114
gilou
Modérateur
Modzilla
Posté le 04-04-2014 à 14:27:06  profilanswer
 

clubber43 a écrit :

Ok, c'est un peu comme en C quand on utilise les pointeurs, passage en valeur/référence si j'ai bien suivi.
 
Pou la modif. avec

Code :
  1. (can_read(\*SERVER, $opt_timeout)) {


C'est ok, le code compile en renvoie le code de connexion impossble.


Bon de toute façon, ça m'a fait découvrir des modules que je n'utilise pas.
Ce code est du code unixien archaïque, en perl moderne, il faut utiliser le module IO::Socket::INET
c'est bien plus simple et ça supporte les time-out, au lieu de tenter de gérer ça soi même à la mimine avec ce can_read.
 
Je récris une version avec et je la poste ici.
 
A+,


---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224116
clubber43
Posté le 04-04-2014 à 14:29:14  profilanswer
 

Et bien merci pour toute l'aide donnée et pour les nouvelles compétences en PERL que j'ai pu apprendre avec nos échanges ^^
 
Petit à petit, je commence à comprendre le fonctionnement de ce langage, qui plus est, à les mêmes fonctionnement que le C ou C++ :
boucle, affichage, ...
 
Voilà,  
bon weekend et @+

n°2224265
clubber43
Posté le 07-04-2014 à 09:08:57  profilanswer
 

Hello :)
 
J'ai travaillé ce weekend sur mon script, et refaits mes lignes de commentaires, calcul de puissances réélles,  
Après pas mal d'essais, je n'ai pas réussi à executer le script de lecture des adresses IP depuis le fichier txt.  
 
Je pensais à un truc, si jamais je prends un fichier csv, je vais lire pas case les différentes adresses IP à interroger,  
je n'obtiendrais pas le bon resultat ?  
 
je regarde comment travailler avec les csv et mon script et je reviendrais poster dans le matin . . .  
 
@+

n°2224278
gilou
Modérateur
Modzilla
Posté le 07-04-2014 à 11:19:12  profilanswer
 

Grosso modo, on veut quelque chose comme:
my $session = session_create();
my @servers = get_servers_list();
my @data = make_data_list()
foreach (@servers) {
  next unless (server_connect($session, $_));
  server_query($session, \@data);
  server_disconnect($session);
}
undef $session;
 
Appelé à intervalles réguliers.
 
La je ne sais pourquoi, le code réseau que j'avais écrit ne marche plus au connect alors qu'il marchait hier matin, j'ai du faire une modif idiote qui est pas bonne (peut être le remplacement de sockaddr_in par pack_sockaddr_in).
Une fois que j'aurais pu tester un peu et que ça tournera (bon, j'émule un avec serveur sur le port tcp 502 qui renvoie la date sur un envoi de "date" pour tester), je te posterai le code.
 
A+,


---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224279
clubber43
Posté le 07-04-2014 à 11:21:06  profilanswer
 

OK, c'est sympa;  
 
Je continue mes recherches de mon coté et je continue d'apprendre ce code.
 
@+merci

n°2224350
gilou
Modérateur
Modzilla
Posté le 07-04-2014 à 23:25:38  profilanswer
 

Bon, j'ai enfin trouvé d'ou venait mon erreur:
Je testais avec un client modbus (qui envoie des données sans \n a la fin) mais mon serveur était trop basique (une boucle sur <$client> ) et était orienté ligne, et donc attendait un \n en fin de ligne et restait bloqué sans.
 
Bon ben maintenant que je sais ce qui faisait foirer mon code, ça va avancer. Je poste ce soir ou demain selon que j'ai le temps ce soir ou pas.
 
A+,


---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224359
clubber43
Posté le 08-04-2014 à 08:43:55  profilanswer
 

Sa marche, merci

n°2224393
gilou
Modérateur
Modzilla
Posté le 08-04-2014 à 12:26:47  profilanswer
 

Bon, comme je peux pas tester en vraie grandeur, il reste peut être des bugs mineurs.  
Voici ce qui devrait coller:

Code :
  1. #!/usr/bin/perl
  2. use strict;
  3. use warnings;
  4. use autodie;
  5.  
  6. use IO::Socket;
  7. use IO::Select;
  8. use Errno qw(EINPROGRESS);
  9.  
  10.  
  11. sub start_connection($) {
  12.   my $server_ip = shift;
  13.   my $server_port = 502;    # MODBUS port
  14.   my $timeout = 5; # délai de 5s pour établir une connection, a ajuster en fonction de vos besoins
  15.  
  16.   #creation d'une socket tcp et d'un indicateur d'état
  17.   my $socket = IO::Socket::INET->new(Proto => 'tcp', Type => SOCK_STREAM);
  18.   unless ($socket) {
  19.     # on pourrait positionner $! pour on message d'erreur
  20.     return 0;
  21.   }
  22.   # et d'un indicateur d'état
  23.   my $select = IO::Select->new($socket);
  24.   unless ($select) {
  25.     # on pourrait positionner $! pour on message d'erreur
  26.     return 0 ;
  27.   }
  28.  
  29.   my $ip_address = inet_aton($server_ip);
  30.   unless ($ip_address) {
  31.     return 0;
  32.   }
  33.  
  34.   $socket->blocking(0);    # mode non-bloquant pour pouvoir vérifier le time-out
  35.   # connection sinon attendre l'établissement avec un timeout
  36.   unless ($socket->connect(pack_sockaddr_in($server_port, $ip_address))) {
  37.     unless ($! == EINPROGRESS and # retour si état autre que EINPROGRESS
  38.         $select->can_write($timeout) and # attente (blocante) au plus de $timeout de la disponibilité
  39.         $socket->connected) {         # vérification du statut
  40.       $! = $socket->sockopt(SO_ERROR);
  41.       $socket->close();
  42.       return 0;
  43.     }
  44.     # on a établi une connection dans le délai imparti
  45.   }
  46.   # repasser en mode bloquant pour la suite
  47.   $socket->blocking(1);
  48.   # verification que la socket est disponible
  49.   unless ($select->can_write($timeout)) {
  50.     # si on est ici, on a sans doute créé une socket pour un hôte non-joignable
  51.     # ou sur un hôte dont le serveur n'est pas démarré
  52.     # mais on a attendu $timeout, bien moins que le délai tcp standard
  53.     # et on évite le message d'erreur du système à ce sujet
  54.     $socket->close();
  55.     return 0;
  56.   }
  57.   # On a une connexion prete a l'emploi
  58.   return { "socket" => $socket, "select" => $select };
  59. }
  60.  
  61.  
  62. sub end_connection($) {
  63.   my $connection = shift;
  64.   $connection->{"socket"}->shutdown(2);
  65.   $connection->{"socket"}->close();
  66. }
  67.  
  68.  
  69. sub modbus_make_packet($$) {
  70.   my ($address, $size) = @_;
  71.   my ($tx_hd_tr_id, $tx_hd_pr_id, $tx_hd_length, $tx_hd_unit_id);
  72.  
  73.   use constant READ_HOLDING_REGISTERS => 0x03; # command code
  74.   $tx_hd_tr_id = int(rand 65536);
  75.   $tx_hd_pr_id = 0;
  76.   $tx_hd_length = 6;
  77.   $tx_hd_unit_id = 1;
  78.   my $tx_hd  = pack("nnnC",    $tx_hd_tr_id, $tx_hd_pr_id, $tx_hd_length, $tx_hd_unit_id);
  79.   my $packet = pack("nnnCCnn", $tx_hd_tr_id, $tx_hd_pr_id, $tx_hd_length, $tx_hd_unit_id, READ_HOLDING_REGISTERS, $address, $size);
  80.   return ($tx_hd, $packet);
  81. }
  82.  
  83.  
  84. sub modbus_check_packet($$) {
  85.   my ($tx_hd, $rx_hd) = @_;
  86.   my ($tx_hd_tr_id, $tx_hd_pr_id, $tx_hd_length, $tx_hd_unit_id) = unpack("nnnC", $tx_hd);
  87.   my ($rx_hd_tr_id, $rx_hd_pr_id, $rx_hd_length, $rx_hd_unit_id) = unpack("nnnC", $rx_hd);
  88.   # Vérifie la cohérence de l'entête
  89.   if (($rx_hd_tr_id == $tx_hd_tr_id) and
  90.       ($rx_hd_pr_id == $tx_hd_pr_id) and
  91.       ($rx_hd_unit_id == $tx_hd_unit_id) and
  92.       ($rx_hd_length < 256)) {
  93.     return $rx_hd_length;
  94.   }
  95.   return 0;
  96. }
  97.  
  98.  
  99. sub get_value($$) {
  100.   my ($connection, $param) = @_;
  101.   my ($socket, $select) = ($connection->{"socket"}, $connection->{"select"});
  102.   my $timeout = 1;        # delai de 1s a ajuster selon besoin.
  103.  
  104.   my ($tx_hd, $packet) = modbus_make_packet($param->{"address"}, $param->{"size"});
  105.   # Emission de la requête vers le serveur
  106.   send($socket, $packet, 0);
  107.   # Attente d'une réponse échec si timeout
  108.   unless ($select->can_read($timeout)) {
  109.     return (0, 0);
  110.   }
  111.   my $buffer;
  112.   # Réception de l'entête depuis le serveur
  113.   recv($socket, $buffer, 7, 0);
  114.   # vérification de l'en tête
  115.   my $datalength = modbus_check_packet($tx_hd, $buffer);
  116.   unless ($datalength ) {
  117.     return (0, 0);
  118.   }
  119.   # Réception du corps du message
  120.   recv($socket, $buffer, $datalength-1, 0);
  121.   # Décodage du corps du message
  122.   my ($rx_bd_fc, $rx_body) = unpack "Ca*", $buffer;
  123.   # Vérification du statut d'exception
  124.   if ($rx_bd_fc > 0x80) {
  125.     return (0, 0);
  126.   }
  127.   ## Lecture de mot
  128.   my ($rx_bd_bc, $rx_read_word_data) = unpack "Ca*", $rx_body;
  129.   my ($val1, $val2, $val3);
  130.   my $result;
  131.   if ($param->{"size"} == 1) {
  132.     $result = unpack 'n', $rx_read_word_data;
  133.     if ($param->{"signed"}) {
  134.       $result -= 2**16;
  135.     }
  136.   } elsif ($param->{"size"} == 2) {
  137.     ($val1, $val2) = unpack 'nn', $rx_read_word_data;
  138.     $result = $val2 * (2**16) + $val1;
  139.     if ($param->{"signed"}) {
  140.       $result -= 2**32;
  141.     }
  142.   } elsif ($param->{"size"} == 3) {
  143.     ($val1, $val2, $val3) = unpack 'nnn', $rx_read_word_data;
  144.     $result = $val3 * (2**32) + $val2 * (2**16) + $val1;
  145.     if ($param->{"signed"}) {
  146.       $result -= 2**48;
  147.     }
  148.   }
  149.   return (1, $result);
  150. }
  151.  
  152.  
  153. sub get_values($%) {
  154.   my ($connection, %params) = @_;
  155.   my %values;
  156.   foreach (sort {$a cmp $b} (keys %params)) {
  157.     my ($status, $val) = get_value($connection, params{$_});
  158.     next unless ($status);
  159.     $values{$_} = $val;
  160.   }
  161.   return %values;
  162. }
  163.  
  164.  
  165. sub make_servers_list ($) {
  166.   my @servers;
  167.   my $fh;
  168.  
  169.   if (open($fh, "<", shift)) {
  170.     @servers = grep {s/^\s*(.*)\s*;\s*/$1/} <$fh>;
  171.     close $fh;
  172.   }
  173.   return @servers;
  174. }
  175.  
  176.  
  177. sub make_params_list () {
  178.   # paramètres pour les différentes requêtes effectuées
  179.   my %params;
  180.   # courant
  181.   $params{"COURANT_1"} = {address => 0x0E, size => 2, signed => 1};
  182.   $params{"COURANT_2"} = {address => 0x10, size => 2, signed => 1};
  183.   $params{"COURANT_3"} = {address => 0x12, size => 2, signed => 1};
  184.   $params{"COURANT_M"} = {address => 0x16, size => 2, signed => 1};
  185.   # phase
  186.   $params{"DEPHASAGE_1"} = {address => 0x18, size => 1, signed => 1};
  187.   $params{"DEPHASAGE_1"} = {address => 0x19, size => 1, signed => 1};
  188.   $params{"DEPHASAGE_1"} = {address => 0x1A, size => 1, signed => 1};
  189.   $params{"DEPHASAGE_M"} = {address => 0x1B, size => 1, signed => 1};
  190.   # puissance
  191.   $params{"PUISSANCE"} = {address => 0x109, size => 3, signed => 0};
  192.  
  193.   return %params;
  194. }
  195.  
  196.  
  197. sub session () {
  198.   my $logfile = 'C:/modlog.txt';
  199.   my @servers = make_servers_list('C:/adresses_ip.txt');
  200.   my %params = make_params_list();
  201.   foreach (@servers) {
  202.     my $connection = start_connection($_);
  203.     next unless ($connection);
  204.     my %values = get_values($connection, %params);
  205.     # log_write($logfile, $_, %values);
  206.     end_connection($connection);
  207.     undef $connection;
  208.   }
  209. }
  210.  
  211. # Programme principal
  212. use AnyEvent::DateTime::Cron;
  213. session();
  214. # boucle infinie, a stopper avec un kill
  215. # remplacer le '* * * * *' par 'mm hh * * *' pour un log tous les jours a hh:mm
  216. my $cron = AnyEvent::DateTime::Cron->new();
  217. $cron->add( '*/3 * * * *' => \&session ); # toutes les 3 minutes, pour tester
  218. $cron->start->recv;


C'est sans doute améliorable (par exemple en passant des références sur les listes et hashes aux subs), mais comme les listes ne sont pas grosses a priori ce doit être mineur
Je te laisse écrire une fonction qui fait quelque chose des résultats.
Il y a deux délais ajustables pour les timeout, un de 5s pour établir la connexion au serveur et un de 1s pour lire une donnée serveur. A adapter à votre situation.
A+,


Message édité par gilou le 08-04-2014 à 12:32:59

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224404
clubber43
Posté le 08-04-2014 à 13:54:49  profilanswer
 

OK,  
je le testerais cette après-midi en "vrai" et j'essaie de le debugger. Aucun problème.
 
Merci beaucoup pour le coup de main.
 
Je reviendrais ici dès que j'avance le script.
 
Ju

n°2224411
gilou
Modérateur
Modzilla
Posté le 08-04-2014 à 14:31:45  profilanswer
 

La partie réseau devrait fonctionner sans pb, je l'ai testé sur ma bécanes + 3 adresses locales (deux PC sur lesquels je faisait tourner un client a 2 balles et une adresse fausse) et elle marche bien.
C'est du code relativement standard (a condition de mettre la main dessus :D) le seul truc que j'ai rajouté, c'est  
# verification que la socket est disponible
 unless ($select->can_write($timeout)) {
   # si on est ici, on a sans doute créé une socket pour un hôte non-joignable
   # ou sur un hôte dont le serveur n'est pas démarré
   # mais on a attendu $timeout, bien moins que le délai tcp standard
   # et on évite le message d'erreur du système à ce sujet
   $socket->close();
   return 0;
 }
Parce que sous Windows, ça retourne connecté systématiquement, quelle que soit l'adresse passée (vraie ou fausse), et le flag connected est positionné aussi, tandis que le test avec select est OK: il ne passe que si il y a une bécane avec un serveur dispo en face. Je suppose que sur une bécane unix, ça suit l'autre partie, avec les tests sur EINPROGRESS et la suite.  
Eb tout cas, ça m'aura permis d'apprendre différentes choses sur le fonctionnement de la communication a travers un socket (en général, je faisait ça en C en suivant un modèle prédéfini, sans me poser de questions, la j'ai du comprendre un peu mieux comment ça fonctionnait en particulier pour les select)
 
 
Le code qui simule cron fonctionne bien (quoique je l'ai testé sur un truc bidon qui envoie du texte en console, mais il n'y a pas de raison que ça coince avec session).
Le code le moins testé, c'est get_value et ce qu'il appelle, parce qu'il m'aurait fallu un vrai serveur, mais il est basé sur le code précédent, qui marchait (faut espérer que j'ai pas introduit de bug en le simplifiant).
 
Au fait, comment se fait il que tu interroges plusieurs compteurs?
 
A+,


Message édité par gilou le 08-04-2014 à 14:35:09

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224412
clubber43
Posté le 08-04-2014 à 14:40:42  profilanswer
 

En fait,  
 
Le but est de remonter la consommation de plusieurs compteurs disposés dans tout le batiment.
le constructeur vend l'appareil qui permet de faire cela 900€ + 1650€ pour le logiciel, du coup,  
pas de moyens financiers et donc systeme D ^^
 
Ils ont chacun leur adresses IP et leur emplacements spécifiques du coup, je les interroges à intervalle de temps constant (1fois par heure) et je regroupe le tout sur une bdd sur un serveur...
 
C'est à peu près tout pour le moment, mais je pense qu'il va évoluer au fil du temps, vu que je commence à avoir pas mal d'idée sur ce projet !!
 
Je teste ce script dans 5 minutes, j'arrive bientot sur mon PC;
 
@
merci

n°2224417
clubber43
Posté le 08-04-2014 à 14:53:30  profilanswer
 

Concernant la boucle avec Cron,  
lors de lexecution, il me dit qu'il ne peut pas localiser AnyEvent/DateTime/Cron.pm
 
il doit manquer un morceau de la bibliotheque PERL sur mon PC non ?  
COmme lorsque j'avais pas installer Strawberry, il ne connaissait pas PERL ^^
 
La fonction Cron, en fait, c'est elle qui permet de créer la boucle d'attente entre 2 exports si j'ai bien tout suivi.
 
ju
 
merc

Message cité 1 fois
n°2224418
gilou
Modérateur
Modzilla
Posté le 08-04-2014 à 14:53:49  profilanswer
 

> et je regroupe le tout sur une bdd sur un serveur
Donc utilisation du module DBI qui va bien et appel an niveau de log_write($logfile, $_, %values);  
Plutot que logfile, tu peux avoir une ouverture de la bdd en début de session et une fermeture en fin de session.
 
Dans l'idéal, session prendrait des paramètres, mais on ne peut pas a cause de l'appel au simili cron.
Néanmoins, tel que c'est fait, si tu change C:/adresses_ip.txt entre deux sessions, ça sera pris en compte.
Des améliorations peuvent être apportées (un timeout spécifique par serveur, par exemple) mais c'est a toi de regarder une foi que ça fonctionnera.
 
Pour le test que tu vas faire, ajoute un  
use Data::Dumper;
après  
use Errno qw(EINPROGRESS);
et ajoutes un
print Dumper(%values), "\n";
avant le
end_connection($connection);
pour tracer les résultats, sinon, il n'y aura rien en sortie de l'exécution.
 
A+,


Message édité par gilou le 08-04-2014 à 14:56:54

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224419
clubber43
Posté le 08-04-2014 à 14:54:40  profilanswer
 

A ok, je note tout ça.

n°2224420
gilou
Modérateur
Modzilla
Posté le 08-04-2014 à 14:56:11  profilanswer
 

clubber43 a écrit :

Concernant la boucle avec Cron,  
lors de lexecution, il me dit qu'il ne peut pas localiser AnyEvent/DateTime/Cron.pm
 
il doit manquer un morceau de la bibliotheque PERL sur mon PC non ?  
COmme lorsque j'avais pas installer Strawberry, il ne connaissait pas PERL ^^
 
La fonction Cron, en fait, c'est elle qui permet de créer la boucle d'attente entre 2 exports si j'ai bien tout suivi.
 
ju
 
merc

C'est le perl d'activestate que tu as installé, non?
Tu fais "ppm" dans une boite dos, quand PPM est lancé, tu choisis AnyEvent-DateTime-Cron a installer dans la liste des modules, tu l'installes et voila...
cron, c'est l'utilitaire standard unix pour faire ça.
 
$cron->start->recv;
c'est une notation vicieuse:
On fait d'abord $cron->start() ça renvoie un objet du bon type (je sais plus quoi) et sur cet objet, on exécute la méthode recv() qui est une boucle d'attente qui déclenche l'appel à la procédure session quand la condition matérialisée par '*/3 * * * *' est remplie (vu la résolution, je suppose que la boucle teste toute les minutes).
 
A+,


Message édité par gilou le 08-04-2014 à 15:02:19

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224421
clubber43
Posté le 08-04-2014 à 14:58:42  profilanswer
 

Et bien, j'ai installé le module Strawberry pour avoir accès à la console PERL et après j'ai aussi copier la fonction MbtGet mais j'ai pas vu de fichier ou autre qui s'appelaient 'activestate '
 
Je vais installer le module Cron de suite

n°2224422
gilou
Modérateur
Modzilla
Posté le 08-04-2014 à 15:04:22  profilanswer
 

Ah tu utilises Strawberry perl. Je ne l'utilise pas, j'utilise le perl de ActiveState, ActivePerl (gratuit lui aussi dans sa version 'community edition') qui a un outil intégré de gestion de modules, PPM (perl package manager).
 
A+,


---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224423
clubber43
Posté le 08-04-2014 à 15:05:17  profilanswer
 

Du coup, j'ai telecharger le code de  AnyEvent et la je l'ai mis dans un fichier txt que je vais mettre à la source pour qu'il el trouve.
 
package AnyEvent::DateTime::Cron;
 
use warnings;
use strict;
use DateTime();
use DateTime::Event::Cron();
use DateTime::Event::Cron::Quartz();
use AnyEvent();
our $VERSION = 0.08;
 
#===================================
sub new {
#===================================
    my ( $class, %params ) = @_;
 
    foreach my $key ( keys %params ) {
     die "Unknown param '$key'" unless $key =~ /^(time_zone|quartz)$/;
    }
 
    $params{time_zone} = DateTime::TimeZone->new(name => $params{time_zone})
        if $params{time_zone};
 
    $params{quartz} = 0 unless defined $params{quartz};
 
    return bless {
        _jobs      => {},
        _debug     => 0,
        _id        => 0,
        _running   => 0,
        _time_zone => $params{time_zone},
        _quartz    => $params{quartz},
    }, $class;
}
 
#===================================
sub add {
#===================================
    my $self = shift;
    my @args = ref $_[0] eq 'ARRAY' ? @{ shift() } : @_;
    while (@args) {
        my $cron = shift @args;
        my ( $cb, %params );
        while (@args) {
            my $key = shift @args;
            if ( ref $key eq 'CODE' ) {
                $cb = $key;
                last;
            }
            die "Unknown param '$key'"
                unless $key =~ /^(name|single)$/;
            $params{$key} = shift @args;
        }
        die "No callback found for cron entry '$cron'"
            unless $cb;
 
        my $event;
        if ($self->{_quartz}) {
            $event = DateTime::Event::Cron::Quartz->new($cron);
        }
        else {
            $event = DateTime::Event::Cron->new($cron);
        }
 
        my $id    = ++$self->{_id};
        $params{name} ||= $id;
        my $job = $self->{_jobs}{$id} = {
            event    => $event,
            cb       => $cb,
            id       => $id,
            watchers => {},
            %params,
        };
 
        $self->_schedule($job)
            if $self->{_running};
    }
    return $self;
}
 
#===================================
sub delete {
#===================================
    my $self = shift;
    my @ids = ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;
 
    for (@ids) {
        print STDERR "Deleting job '$_'\n"
            if $self->{_debug};
 
        if ( my $job = delete $self->{_jobs}{$_} ) {
            $job->{watchers} = {};
        }
        elsif ( $self->{_debug} ) {
            print STDERR "Job '$_' not found\n";
        }
    }
    return $self;
}
 
#===================================
sub start {
#===================================
    my $self = shift;
    my $cv = $self->{_cv} = AnyEvent->condvar;
 
    $cv->begin( sub { $self->stop } );
 
    $self->{_signal} = AnyEvent->signal(
        signal => 'TERM',
        cb     => sub {
            print STDERR "Shutting down\n" if $self->{_debug};
            $cv->end;
        }
    );
    $self->{_running} = 1;
    $self->_schedule( values %{ $self->{_jobs} } );
 
    return $cv;
}
 
#===================================
sub stop {
#===================================
    my $self = shift;
    $_->{watchers} = {} for values %{ $self->{_jobs} };
 
    my $cv = delete $self->{_cv};
    delete $self->{_signal};
    $self->{_running} = 0;
 
    $cv->send;
    return $self;
}
 
#===================================
sub _schedule {
#===================================
    my $self = shift;
 
    my $time_zone = $self->{_time_zone};
 
    AnyEvent->now_update();
    my $now_epoch = AnyEvent->now;
    my $now       = DateTime->from_epoch( epoch => $now_epoch );
    my $debug     = $self->{_debug};
 
    $now->set_time_zone($time_zone) if $time_zone;
 
    for my $job (@_) {
        my $name       = $job->{name};
 
        my $next_run;
        if ($self->{_quartz}) {
            $next_run = $job->{event}->get_next_valid_time_after($now);
        }
        else {
            $next_run = $job->{event}->next($now);
        }
 
        $next_run->set_time_zone($time_zone) if $time_zone;
 
        my $next_epoch = $next_run->epoch;
        my $delay      = $next_epoch - $now_epoch;
 
        print STDERR "Scheduling job '$name' for: $next_run\n"
            if $debug;
 
        my $run_event = sub {
            print STDERR "Starting job '$name'\n"
                if $debug;
 
            $self->{_cv}->begin;
            delete $job->{watchers}{$next_epoch};
 
            $self->_schedule($job);
 
            if ( $job->{single} && $job->{running}++ ) {
                print STDERR "Skipping job '$name' - still running\n"
                    if $debug;
            }
            else {
                eval { $job->{cb}->( $self->{_cv}, $job ); 1 }
                    or warn $@ || 'Unknown error';
                delete $job->{running};
                print STDERR "Finished job '$name'\n"
                    if $debug;
            }
 
            $self->{_cv}->end;
        };
 
        $job->{watchers}{$next_epoch} = AnyEvent->timer(
            after => $delay,
            cb    => $run_event
        );
    }
}
 
#===================================
sub debug {
#===================================
    my $self = shift;
    $self->{_debug} = shift if @_;
    return $self;
}
 
#===================================
sub jobs { shift->{_jobs} }
#===================================
 
1;
 
=pod
 
=encoding UTF-8
 
=head1 NAME
 
AnyEvent::DateTime::Cron - AnyEvent crontab with DateTime::Event::Cron
 
=head1 VERSION
 
version 0.08
 
=head1 SYNOPSIS
 
    AnyEvent::DateTime::Cron->new()
        ->add(
            '* * * * *'   => sub { warn "Every minute"},
            '*/2 * * * *' => sub { warn "Every second minute"},
          )
        ->start
        ->recv
 
    $cron = AnyEvent::DateTime::Cron->new();
    $cron->debug(1)->add(
        '* * * * *', name   => 'job_name', single => 1,  sub {'foo'},
        ...
    );
 
    $cron->delete($job_id,$job_id...)
 
    $cv = $cron->start;
    $cv->recv;
 
    AnyEvent::DateTime::Cron->new(time_zone => 'local');
        ->add(
            '* * * * *'   => sub { warn "Every minute"},
            '*/2 * * * *' => sub { warn "Every second minute"},
          )
        ->start
        ->recv
 
=head1 DESCRIPTION
 
L<AnyEvent::DateTime::Cron> is an L<AnyEvent> based crontab, which supports
all crontab formats recognised by L<DateTime::Event::Cron>.
 
It allows you to shut down a running instance gracefully, by waiting for
any running cron jobs to finish before exiting.
 
=head1 METHODS
 
=head2 new()
 
    $cron = AnyEvent::DateTime::Cron->new(
        time_zone => ...
        quartz    => 0/1
    );
 
Creates a new L<AnyEvent::DateTime::Cron> instance - takes optional parameters
time_zone and quartz.
 
time_zone can will be used to set the time_zone for any DateTime objects that
are used internally.
 
if quartz is set to a true value then this class will use switch to using
L<DateTime::Event::Cron::Quartz> internally, which will allow the use of seconds
in the cron expression. See the DateTime::Event::Cron::Quartz for details on
writing a proper quartz cron expression.
 
=head2 add()
 
    $cron->add(
        '* * * * *',                                     sub {...},
        '* * * * *', name   => 'job_name', single => 1,  sub {...},
        ...
    );
 
Use C<add()> to add new cron jobs.  It accepts a list of crontab entries,
optional paremeters and callbacks.
 
The C<name> parameter is useful for debugging, otherwise the auto-assigned
C<ID> is used instead.
 
The C<single> parameter, if C<true>, will only allow a single instance of
a job to run at any one time.
 
New jobs can be added before running, or while running.
 
See L</"CALLBACKS"> for more.
 
=head2 delete()
 
    $cron->delete($job_id,$job_id,....)
 
Delete one or more existing jobs, before starting or while running.
 
=head2 start()
 
    my $cv = $cron->start;
    $cv->recv;
 
Schedules all jobs to start at the next scheduled time, and returns an
L<AnyEvent condvar|http://metacpan.org/module/AnyEvent#CONDITION-VARIABLES>.
 
The cron loop can be started by calling C<recv()> on the condvar.
 
=head2 stop()
 
    $cron->stop()
 
Used to shutdown the cron loop gracefully. You can also shutdown the cron loop
by sending a C<TERM> signal to the process.
 
=head2 jobs()
 
    $job = $cron->jobs
 
Returns a hashref containing all the current cron jobs.
 
=head2 debug()
 
    $cron->debug(1|0)
 
Turn on debugging.
 
=head1 CALLBACKS
 
A callback is a coderef (eg an anonymous subroutine) which will be called
every time your job is triggered. Callbacks should use C<AnyEvent> themselves,
so that they run asynchronously, otherwise they can block the execution
of the cron loop, delaying other jobs.
 
Two parameters are passed to your callback: the main C<$cv> of the cron loop,
and the C<$job_description> which contains various details about the current
job.
 
The C<$cv> is the most important parameter, as it allows you to control how
your cron loop will shut down.  If your callback doesn't use
C<AnyEvent> and is blocking, then your callback will complete before it
returns to the cron loop.
 
However, if your callback is running asynchronously (and it really should),
then you can block the cron loop from responding to a L</"stop()"> request
until your job has completed:
 
    sub {
        my $cv = shift;
        $cv->begin;
        do_something_asynchronous( cb => sub { $cv->end })
    }
 
Callbacks are called inside an C<eval> so if they throw an error, they
will warn, but won't cause the cron loop to exit.
 
=head1 AUTHORS
 
=over 4
 
=item *
 
Clinton Gormley <drtech@cpan.org>
 
=item *
 
Andy Gorman <agorman@cpan.org>
 
=back
 
=head1 COPYRIGHT AND LICENSE
 
This software is copyright (c) 2013 by Clinton Gormley.
 
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
 
=cut
 
__END__
 
# ABSTRACT: AnyEvent crontab with DateTime::Event::Cron
 
 ^^

Message cité 1 fois
n°2224425
clubber43
Posté le 08-04-2014 à 15:14:15  profilanswer
 

Parcontre, le fichier que j'ai créé, je le créé avec quelle extension, .pl ou .pm du coup car sur internet, je n'ai pas trouvé de bonne extension et d'endroit ou le mettre.
lol
 
Internet est bien, mais a utiliser avec parcimonie lol

n°2224434
gilou
Modérateur
Modzilla
Posté le 08-04-2014 à 15:44:18  profilanswer
 

clubber43 a écrit :

Du coup, j'ai telecharger le code de  AnyEvent et la je l'ai mis dans un fichier txt que je vais mettre à la source pour qu'il el trouve.


Ça marche pas comme ça: Il peut y avoir des dll a compiler pour faire marcher un module, etc.
Je ne sais pas comment ça fonctionne pour Strawberry Perl, mais il y a surement un script d'install, au minimum.
C'est pour cela que j'utilise le Perl d'Active State: Certains trucs sont déjà compilés, et l'installeur met les différents morceaux aux bons endroits, et pour les autres, il a un outil (CPAN) qui essaye de recompiler ce qu'il faut (ça installe mingw entre autres). Bref, c'est plus rapide à utiliser pour les modules pas déjà installés.
Il y a surement une doc dans Strawberry perl qui va te donner la marche à suivre.
A+,


Message édité par gilou le 08-04-2014 à 15:45:28

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224436
clubber43
Posté le 08-04-2014 à 15:46:33  profilanswer
 

J'ai lancé le telechargement de ActivePErl à l'instant.
Du coup j'aurais le bon truc au bon endroit si j'ai la même version
Cela devrai aller.
 
Parcontre, je dois m'absenter un moment pour Rdv de 16 à 18.
Je regarde tout cela ce soir en rentrant.
 
Mais j'installerais ActivePErl du coup.
 
@+

n°2224439
gilou
Modérateur
Modzilla
Posté le 08-04-2014 à 15:55:04  profilanswer
 

De toute façon, pour démarrer, tu n'as pas besoin de la partie avec cron, tu peux juste tester simplement avec le premier appel: session();
 
A+,


---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224440
clubber43
Posté le 08-04-2014 à 15:56:15  profilanswer
 

oui, je testerai tout ça ce soir à  la maison,  
La direction le medecin . . . c'est moins drole....
 
Active Perl est en installation. j'ai pris le package free car sinon c'est le payant à 1000$ lol

n°2224442
gilou
Modérateur
Modzilla
Posté le 08-04-2014 à 15:59:26  profilanswer
 

Il n'y a aucune raison de prendre le package payant, sauf si tu fais du serveur web de pro avec utilisation de perl entre autres.
 
A+,


---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2224450
clubber43
Posté le 08-04-2014 à 16:09:21  profilanswer
 

OK.
Et puis je n'ai pas les moyens d'avoir ça ^^

n°2224512
clubber43
Posté le 08-04-2014 à 23:16:19  profilanswer
 

Bon, en attendant de remettre en forme le dernier programme,  
Je souhaite lancer l ancien code en "prod" et je veux y rajouter l'export des données vers un CSV,  
 
Je peux garder le script précédent pour l'export des valeurs ?  
 

Code :
  1. # Affichage des valeurs recues
  3. sub disp_data { 
  4. open(my $fh, ">>", 'C:/julien/test.csv' ) || die ('Impossible de créer le fichier "c:/julien/test.csv"' );
  5.   foreach (@_)
  6. {
  7.   printf( $fh "%05d;", $_);
  8. }
  9. printf ($fh "\n" );
  10. close ($fh);


Et le mettre en forme pour mon script ?  
 
 
Mais du coup, les boucles de temps sub_query ne fonctionneront pas du coup parocntre?
 
merci
 
ju

n°2224523
gilou
Modérateur
Modzilla
Posté le 09-04-2014 à 03:34:14  profilanswer
 

Les valeurs reçues sont dans un hash %values dont les clés sont les mêmes que celles du hash %params dorénavant.
La technique pour ordonner les clés du hash et faire une boucle sur les clés ordonnées est utilisée dans la version antérieure du code, il vous suffit de l'adapter ici.
 
Note: pour mettre au point, je vous conseille d'ajouter
use Data::Dumper;
dans la liste des use en tête de fichier, et de faire
print Dumper($var);  
pour voir ce que contient une variable qui peut être un scalaire ($var), une liste (@var), un hash (%var), etc.
 
A+,

Message cité 1 fois

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
mood
Publicité
Posté le   profilanswer
 

 Page :   1  2  3  4  5  6  7
Page Suivante
Page Précédente
Haut de page 

Aller à :
Ajouter une réponse
 

Sujets relatifs
Copier données en ligne par colonneComment génerer un fichier csv à partir d'une base de données?
perl + xml[Perl] Créer un graph RRD avec RRDTool::OO
[Résolu][Perl] XML::DOM Comment avoir une belle indentation?Programmation Java lecture base de données
[VBA-Excel] Comment appeler un fichier pour récupérer des données ?extraction de donnees
Récupération données d'un site PHPRécupérer des données d'un fichier xml
Plus de sujets relatifs à : [Résolu] Export données en perl

Forum MesDiscussions.Net, Version 2010.2
(c) 2000-2011 Doctissimo
Page générée en 0.372 secondes

Copyright © 1997-2022 Hardware.fr SARL (Signaler un contenu illicite / Données personnelles) / Groupe LDLC / Shop HFR