diff options
Diffstat (limited to 'Ivy.pm')
| -rw-r--r-- | Ivy.pm | 398 |
1 files changed, 200 insertions, 198 deletions
@@ -1,6 +1,6 @@ # -# Ivy, Perl interface -# +# Ivy, Perl interface +# # Copyright 1997-2002 # Centre d'Études de la Navigation Aérienne # @@ -17,20 +17,18 @@ # modify it under the terms of the GNU LGPL Libray General Public License # as published by the Free Software Foundation; either version 2 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. -# +# # You should have received a copy of the GNU Library General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA, # or refer to http://www.gnu.org/copyleft/lgpl.html # -# $Id$ -# $Name$ -############################################################################# +################################################################## package Ivy ; @@ -43,7 +41,7 @@ use IO::Socket::Multicast; use vars qw($VERSION); -# to compute the VERSION from the CVS tag (or if no tag, as the cvs file revision) +# to compute the VERSION from the CVS tag (or if no tag, as the cvs file revision) my $TAG= q$Name$; my $REVISION = q$Revision$ ; ($VERSION) = $TAG =~ /^\D*([\d_]+)/ ; @@ -71,17 +69,17 @@ sub new ($%); # verifie la validite de tous les parametres, # de new qui prevalent sub start; # debut de l'integration au bus : - # - cree la socket d'application, recupere le no + # - cree la socket d'application, recupere le no # de port # - cree la socket supervision # - envoie le "no de port" - # - bind le file descriptor de la socket de - # supervision a la fonction getBonjour pour + # - bind le file descriptor de la socket de + # supervision a la fonction getBonjour pour # traiter les bonjours - # - bind le fd de connection sur la fonction + # - bind le fd de connection sur la fonction # getConnections # pour etablir les connections "application" - + sub DESTROY ($); # - envoie un BYE et clot les connections #sub bindRegexp ($$$) ; # permet d'associer une regexp avec un callBack @@ -89,7 +87,7 @@ sub DESTROY ($); # - envoie un BYE et clot les connections sub bindDirect; # permet d'associer un identifiant de msg direct # avec une fonction de callBack, ou de l'annuler - + sub sendMsgs; # envoie une liste de messages sub sendAppNameMsgs; # envoie une liste de messages precedes # du nom de l'application @@ -97,13 +95,13 @@ sub sendDirectMsgs; # envoie une liste de messages directs a une appli sub sendDieTo; # envoie un <<kill>> a une appli sub ping; # teste qu'une appli soit encore vivante sub mainLoop (); # la mainloop locale (sans tk) -sub stop (); # methode de classe : on delete les bus, mais +sub stop (); # methode de classe : on delete les bus, mais # on reste dans la mainloop sub exit (); # methode de classe : on delete tous les # bus (donc on ferme proprement toutes les # connexions). - # Si on est en mainloop locale on sort de la - # mainloop, le code qui suit l'appel mainLoop + # Si on est en mainloop locale on sort de la + # mainloop, le code qui suit l'appel mainLoop # sera execute. # par contre si on est en mainloop Tk, # il faut en plus detruire la mainwindow @@ -131,7 +129,7 @@ sub _sendWantedRegexp ($$); # envoie les regexp a l'appli distante sub _sendLastRegexpToAllreadyConnected ($$) ; # envoie la derniere regexp # pushee dans @recCbList - # a toutes les applis deja + # a toutes les applis deja # connectees sub _removeFileDescriptor ($$); # on vire un fd et les structures associees sub _sendErrorTo ($$$); #(fd, error) envoie un message d'erreur a un fd @@ -141,18 +139,18 @@ sub _pong ($$); # (fd) sub _tkFileEvent ($$); # associe un fd a un callback pour la mainloop tk sub _scanAfter () ; # parse si il faut appeler un callback associe a un after sub _myCanRead (); # interface au select -sub _scanConnStatus ($$$$); # verifie les connections effectuees et - # appelle la fonction $statusFunc -sub _inetAdrByName ($$); # transforme une adresse inet native en chaine +sub _scanConnStatus ($$$$); # verifie les connections effectuees et + # appelle la fonction $statusFunc +sub _inetAdrByName ($$); # transforme une adresse inet native en chaine # $host:$port sub _toBePruned ($$$); sub _parseIvyBusParam ($); # prends une adresse de bus de la forme # 143.196.53,DGAC-CENATLS:2010 et # renvoie une liste de deux elements : - # un numero de port et une ref sur une + # un numero de port et une ref sur une # liste d'adresses addr_inet -sub _substituteEscapedChar ($$); #permet de transformer une regexp etendue +sub _substituteEscapedChar ($$); #permet de transformer une regexp etendue # 'perl' en regexp de base ############################################################################# @@ -187,9 +185,9 @@ use constant REG_PERLISSISME => ('w' => '[a-zA-Z0-9_]', 'W' => '[^a-zA-Z0-9_]', 's' => "[\t ]", 'S' => "[^\t ]", - 'd' => '[0-9]', + 'd' => '[0-9]', 'D' => '[^0-9]', - 'n' => '', # Il ne faut pas mettre d'\n : + 'n' => '', # Il ne faut pas mettre d'\n : # c'est un delimiteur pour le bus 'e' => '[]') ; @@ -238,24 +236,24 @@ my $constantIndexer =0; # pointeur sur la fonction permettant d'associer # des callbacks a un file desc, (ainsi que de les enlever) -my $fileEventFunc; +my $fileEventFunc; # dans le cas ou l'on soit dans une mainLoop # locale, cette var pointe une un objet # de type IO::Select; -my $localLoopSel; +my $localLoopSel; # table d'ass. handle -> callback -my %localBindByHandle; +my %localBindByHandle; -# tableau d'ass [AFTER ou REPEAT, +# tableau d'ass [AFTER ou REPEAT, # timeTotal, deadLine, [callback, arg, arg, ...]] -my %afterList=(); +my %afterList=(); -my $afterId = 0; +my $afterId = 0; # timeout le plus petit pour le select -my $selectTimout = MAX_TIMOUT; +my $selectTimout = MAX_TIMOUT; # liste des bus actifs @@ -291,7 +289,7 @@ use constant cnnxion => $constantIndexer++; use constant buffByConn => $constantIndexer++; use constant broadcastPort => $constantIndexer++; use constant broadcastBuses => $constantIndexer++; -use constant useMulticast => $constantIndexer++; +use constant useMulticast => $constantIndexer++; use constant appName => $constantIndexer++; use constant messWhenReady => $constantIndexer++; @@ -301,7 +299,7 @@ use constant messWhenReady => $constantIndexer++; sub init { my $class = shift if (@_ and $_[0] eq __PACKAGE__); - my (%options) = @_; + my (%options) = @_; # valeurs par defaut pour le parametre : variable d'environnement # ou valeur cablee, a defaut @@ -310,26 +308,26 @@ sub init BROADCAST_ADDRS.':'.BROADCAST_PORT; my %optionsAndDefaults = ( #PARAMETRES OBLIGATOIRES - -loopMode => undef, + -loopMode => undef, # TK ou LOCAL - - -appName => undef, + + -appName => undef, # nom de l'appli - + # PARAMETRES FACULTATIFS (avec valeurs par defaut) - + # les adresses de reseau sur lesquelles ont broadcaste # suivies du No de port : # exemples : "143.196.1.255,143.196.2.255:2010" # "DGAC-CENATLS-PII:DGAC-CENATLS:2010" # ":2010" <= dans ce cas c'est la valeur - # de reseau de broadcast par defaut qui est prise : + # de reseau de broadcast par defaut qui est prise : # 127.255.255.255 c.a.d local a la machine -ivyBus => $default_ivyBus, -messWhenReady => "_APP NAME READY", # message de synchro a envoyer quand pret - + -onDieFunc => [sub {}], # fonction de cb appelee lorsque l'appli a recu l'ordre # de quitter, on peut dans ce callback fermer @@ -341,7 +339,7 @@ sub init # optimisation : si l'on connait les sujets des messages # qu'on envoie, on fournit la liste des sujets # et les regexps qui ne matchent pas - # ces sujets sont eliminees. + # ces sujets sont eliminees. ) ; # on examine toutes les options possibles @@ -357,7 +355,7 @@ sub init } } - # on examine toutes les options fournies, pour detecter les inutiles + # on examine toutes les options fournies, pour detecter les inutiles foreach my $opt (keys %options) { unless (exists ($optionsAndDefaults{$opt})) { carp "Warning in Ivy::init: option $opt is unknown"; @@ -392,14 +390,14 @@ sub init } # end init ############# METHODE DE CLASSE NEW -sub new ($%) +sub new ($%) { - my ($class, %options) = @_; + my ($class, %options) = @_; my $self = []; $#{$self} = $constantIndexer; # on predimensionne le tableau bless ($self, $class); - # on verifie que la methode de classe init ait ete appelee + # on verifie que la methode de classe init ait ete appelee unless ((defined $appName) && ($appName ne '')) { croak "Error in Ivy::new, you should have called Ivy->init () first."; } @@ -437,7 +435,7 @@ sub new ($%) # tableau ass de liste du type # sockId => [fonction, fonction, ...] # pour savoir quoi envoyer a qui - # les fonctions anonymes sont compilees + # les fonctions anonymes sont compilees # dynamiquement a la reception des messages REGEXP # et filtrent les mess a envoyer et les envoient # au besoin @@ -448,11 +446,11 @@ sub new ($%) # pour connaitre la valeur des regexp meme apres compilation $self->[sendRegListSrc] = {}; - # liste des topics qu'on envoie si on + # liste des topics qu'on envoie si on # filtre les regexps $self->[topicRegexps] = []; - # liste de ref sur des couples + # liste de ref sur des couples # (regexp,callBack) les callbacks # sont appeles lors de # la reception de messages en fonction @@ -474,39 +472,39 @@ sub new ($%) # pas par \n, de maniere a resegmenter les messages $self->[buffByConn] = {}; - - my %optionsAndDefaults = ( + + my %optionsAndDefaults = ( -appName => $appName, # nom de l'appli - + # PARAMETRES FACULTATIFS (avec valeurs par defaut) -messWhenReady => $messWhenReady, # message de synchro a envoyer quand pret - + # PARAMETRES FACULTATIFS (avec valeurs par defaut) - + # les adresses de reseau sur lesquelles ont broadcaste # suivies du No de port : # exemples : "143.196.1.255,143.196.2.255:2010" # "DGAC-CENATLS-PII:DGAC-CENATLS:2010" # ":2010" <= dans ce cas c'est la valeur - # de reseau de broadcast par defaut qui est prise : + # de reseau de broadcast par defaut qui est prise : # 127.255.255.255 c.a.d local a la machine -ivyBus => $ivyBus, - + -neededApp => [], # liste des appplis necessaires - + -statusFunc => sub {}, # fonction de callBack qui sera appelee tant que # toutes les applis necessaires ne sont pas presentes, - # et des que toutes les applis necessaires sont + # et des que toutes les applis necessaires sont # presentes, et si une appli necessaire se deconnecte # les trois parametres passes sont : - # [liste des applis presentes], + # [liste des applis presentes], # [liste des applis absentes], - # [table de hash, clefs = applis presentes, + # [table de hash, clefs = applis presentes, # valeurs = nombre d'applis . # normalement ce nombre devrait etre 1, sinon # ca veut dire que plus d'une appli de meme nom @@ -516,10 +514,10 @@ sub new ($%) # optimisation : si l'on connait les sujets des messages # qu'on envoie, on fournit la liste des sujets # et les regexps qui ne matchent pas - # ces sujets sont eliminees. + # ces sujets sont eliminees. ) ; - - + + # on examine toutes les options possibles foreach my $opt (keys %optionsAndDefaults) { # si un parametre a ete fourni, ignorer les valeurs par defaut @@ -532,8 +530,8 @@ sub new ($%) croak "Error in Ivy::new: option $opt is mandatory\n"; } } - - # on examine toutes les options fournies, pour detecter les inutiles + + # on examine toutes les options fournies, pour detecter les inutiles foreach my $opt (keys %options) { unless (exists ($optionsAndDefaults{$opt})) { carp "Warning in Ivy::new, option $opt is unknown"; @@ -548,10 +546,10 @@ sub new ($%) $self->[topicRegexps] = $options{-pruneRegexp} ; $allBuses{$self} = $self; - ($self->[useMulticast], $self->[broadcastPort], $self->[broadcastBuses]) = + ($self->[useMulticast], $self->[broadcastPort], $self->[broadcastBuses]) = _parseIvyBusParam ($options{-ivyBus}); - + return ($self); } # end new @@ -564,7 +562,7 @@ sub DESTROY ($) # pour toutes les connections foreach my $fd (values %{$self->[sockList]}) { - # send ($fd, sprintf (MSG_FMT, BYE, 0, ""), 0) + # send ($fd, sprintf (MSG_FMT, BYE, 0, ""), 0) # or $self->_removeFileDescriptor ($fd); # the 2 previous lines seems to works with other ivy-perl applis # but DO NOT work with ivy-c api. @@ -582,7 +580,7 @@ sub DESTROY ($) $self->[supSock]->close() if ($self->[supSock] and $self->[supSock]->connected()); delete $allBuses{$self}; - # on clot la socket de connection + # on clot la socket de connection # print "DBG> fermeture de connSock ", $self->[connSock], "\n"; # the following test has been expanded to avoid some nasty bug # which appeared when upgrading from perl-tk 800.023 to 800.024 @@ -600,7 +598,7 @@ sub stop () ############## METHODE DE CLASSE EXIT -sub exit () +sub exit () { Ivy::stop (); if (defined $localLoopSel) { @@ -637,14 +635,18 @@ sub start # on memorise tout ca, ce qui evitera par la suite de se # repondre a soi-meme. On le fait sous nos deux noms : # le nom de machine et 'localhost' - my $hostAddr = (gethostbyname (hostname()))[4] ; + my ($n, $al, $t, $l, @hostAddrs) = gethostbyname (hostname()); + foreach my $a (@hostAddrs) { + # print STDERR "DBG> I am ", unpack ('CCCC', $a), $connSock->sockport, "\n"; + $self->[cnnxion]->{"$a:". $connSock->sockport} = "\004"; + } + my $localhostAddr = (gethostbyname ('localhost'))[4] ; - $self->[cnnxion]->{"$hostAddr:". $connSock->sockport} = "\004"; $self->[cnnxion]->{"$localhostAddr:". $connSock->sockport} = "\004"; - + # le message de bonjour à envoyer: "no de version no de port" my $bonjourMsg = sprintf ("%d %d\n", IVY_PROTOCOLE_VERSION, $connSock->sockport()); - + if (!$self->[useMulticast]) { # cree la socket de broadcast $self->[supSock] = IO::Socket::INET->new @@ -655,7 +657,7 @@ sub start $self->[supSock]->sockopt (SO_BROADCAST, 1); foreach my $netBroadcastAddr (@{$self->[broadcastBuses]}) { # print "BroadcastBus: --", $netBroadcastAddr, "--\n"; - send ($self->[supSock], $bonjourMsg, 0, $netBroadcastAddr) or + send ($self->[supSock], $bonjourMsg, 0, $netBroadcastAddr) or carp "Warning in Ivy::start, broadcast of Hello message failed: $!"; } } @@ -664,36 +666,36 @@ sub start $self->[supSock] = IO::Socket::Multicast->new (LocalPort => $self->[broadcastPort], ReuseAddr => 1); - - # Multicast datagrams with initial TTL 0 are restricted to the same host. - # Multicast datagrams with initial TTL 1 are restricted to the same subnet. - # Multicast datagrams with initial TTL 32 are restricted to the same site. - # Multicast datagrams with initial TTL 64 are restricted to the same region. - # Multicast datagrams with initial TTL 128 are restricted to the same continent. - # Multicast datagrams with initial TTL 255 are unrestricted in scope. + + # Multicast datagrams with initial TTL 0 are restricted to the same host. + # Multicast datagrams with initial TTL 1 are restricted to the same subnet. + # Multicast datagrams with initial TTL 32 are restricted to the same site. + # Multicast datagrams with initial TTL 64 are restricted to the same region. + # Multicast datagrams with initial TTL 128 are restricted to the same continent. + # Multicast datagrams with initial TTL 255 are unrestricted in scope. $self->[supSock]->mcast_ttl(64); # $self->[supSock]->mcast_loopback(1); must be 1, which is the default - + foreach my $netMulticastAddr (@{$self->[broadcastBuses]}) { my ($port,$multicastGroupI) = sockaddr_in ($netMulticastAddr); my $multicastGroup = inet_ntoa($multicastGroupI); # print "DBG> MulticastBus: --", $multicastGroup,":$port", "--\n"; $self->[supSock]->mcast_add($multicastGroup); - $self->[supSock]->mcast_send($bonjourMsg, $multicastGroup.":".$port) or + $self->[supSock]->mcast_send($bonjourMsg, $multicastGroup.":".$port) or carp "Warning in Ivy::start, multicast of Hello message failed: $!"; } } # callback pour traiter la reception des bonjours &$fileEventFunc ($self->[supSock], [\&_getBonjour, $self]) ; - + # callback pour traiter les demandes de cxion &$fileEventFunc ($self->[connSock], [\&_getConnections, $self]) ; return $self; } # end start - -############### PROCEDURE BIND REGEXP + +############### PROCEDURE BIND REGEXP sub bindRegexp { my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy; @@ -705,9 +707,9 @@ sub bindRegexp # qu'une appli distante non perl comprenne ces regexp. $regexp =~ s| ( - (?<!\\) \[ # le premier crochet ouvrant non precede d'un \ + (?<!\\) \[ # le premier crochet ouvrant non precede d'un \ .*? # ce qu'il y a dans le crochet, en mode frugal - (?<!\\) \] # le premier crochet fermant non precede d'un \ + (?<!\\) \] # le premier crochet fermant non precede d'un \ ) | _substituteEscapedChar ('inside', $1) @@ -716,14 +718,14 @@ sub bindRegexp $regexp = _substituteEscapedChar ('outside', $regexp); # print ("DBG> regexp = $regexp\n"); - eval {my $test = "a" =~ /$regexp/ } ; # testing the regexp for avoiding + eval {my $test = "a" =~ /$regexp/ } ; # testing the regexp for avoiding if ($@) { carp "Warning in Ivy::bindRegexp, ill-formed regexp: '$original_regexp'" ; return }; if ($cb) { my $id; # on rajoute le couple $regexp, $cb dans la liste des messages # qu'on prend - + # on commence par tester si on a un id libere dans le tableau for ($id=0; $id <= ($#{$self->[recCbList]}+1); $id++) { last unless (defined $self->[recCbList][$id]) && @{$self->[recCbList][$id]->[1]}; @@ -734,32 +736,32 @@ sub bindRegexp _sendLastRegexpToAllreadyConnected ($self, $id) ; } else { - + # on vire le callback, et on se desabonne de cette regexp for (my $id=0; $id <= $#{$self->[recCbList]}; $id++) { - + next unless (defined $self->[recCbList][$id]) && @{$self->[recCbList][$id]->[1]}; - + if ($self->[recCbList][$id]->[0] eq $regexp) { - + $self->[recCbList][$id]->[1] = []; # on envoie le mesage delregexp foreach my $fd (values %{$self->[sockList]}) { send ($fd, sprintf (MSG_FMT, DELREGEXP, $id,""), 0) - or $self->_removeFileDescriptor ($fd); + or $self->_removeFileDescriptor ($fd); } } } } } # end bindRegexp -############### METHODE BIND REGEXP -sub bindDirect +############### METHODE BIND REGEXP +sub bindDirect { my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy; my ($id, $cb) = @_; - + if ($cb) { # on rajoute la $cb dans la liste des messages # qu'on prend @@ -769,8 +771,8 @@ sub bindDirect undef $self->[directCbList][$id]; } } # end bindDirect - -############### PROCEDURE SEND MSGS + +############### PROCEDURE SEND MSGS sub sendMsgs { my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy; @@ -780,7 +782,7 @@ sub sendMsgs # pour tous les messages foreach my $msg (@msgs) { carp "Warning in Ivy::sendMsgs, a message contains a '\\n'. You should correct it:\n'$msg'" if ($msg =~ /\n/) ; - + study ($msg); # pour routes les connections @@ -796,7 +798,7 @@ sub sendMsgs return $total; } # end sendMsgs -############### PROCEDURE SEND MSGS +############### PROCEDURE SEND MSGS sub sendAppNameMsgs { my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy; @@ -825,12 +827,12 @@ sub sendAppNameMsgs -############### PROCEDURE SEND DIRECT MSGS +############### PROCEDURE SEND DIRECT MSGS sub sendDirectMsgs { my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy; my ($to, $id, @msgs) = @_; - + if (defined $to and defined ($self->[appliList]{$to})) { my @fds = @{$self->[appliList]{$to}}; # pour tous les messages @@ -839,7 +841,7 @@ sub sendDirectMsgs foreach my $fd (@fds) { send ($fd, sprintf (MSG_FMT, DIRECT_MSG, $id, "$msg"), 0) - or $self->_removeFileDescriptor ($fd); + or $self->_removeFileDescriptor ($fd); } } return 1; @@ -852,7 +854,7 @@ sub sendDirectMsgs } # end sendDirectMsgs -############### METHOD SEND DIE TO +############### METHOD SEND DIE TO sub sendDieTo { my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy; @@ -861,7 +863,7 @@ sub sendDieTo if (defined $to and defined $self->[appliList]{$to}) { my @fds = @{$self->[appliList]{$to}}; - carp "Attention : in Ivy::sendDieTo big BUG \@fds is empty" + carp "Attention : in Ivy::sendDieTo big BUG \@fds is empty" if (scalar (@fds) == 0); # pour tous les messages @@ -878,12 +880,12 @@ sub sendDieTo } # end sendDieTo -############### METHOD PING +############### METHOD PING sub ping { my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy; my ($to, $timeout) = @_; - + if (defined $to and defined ($self->[appliList]{$to})) { my @fds = @{$self->[appliList]{$to}}; @@ -891,7 +893,7 @@ sub ping # pour tous les messages foreach my $fd (@fds) { send ($fd, sprintf (MSG_FMT, PING, 0, " "), 0) - or $self->_removeFileDescriptor ($fd); + or $self->_removeFileDescriptor ($fd); } } else { @@ -908,7 +910,7 @@ sub mainLoop () unless defined $localLoopSel; my ($fd, @ready, @allDesc); - + while (defined $localLoopSel) { @ready = IO::Select::can_read ($localLoopSel, $selectTimout) ; _scanAfter () ; @@ -926,7 +928,7 @@ sub mainLoop () } # end mainLoop -############### METHODE AFTER +############### METHODE AFTER sub after ($$;$) { # test du premier argument au cas où la fonction est @@ -934,13 +936,13 @@ sub after ($$;$) # de classe shift if ((ref ($_[0]) eq __PACKAGE__) || ($_[0] eq __PACKAGE__)) ; - my ($timeAfter, $cbListRef) = @_; + my ($timeAfter, $cbListRef) = @_; $timeAfter /= 1000; $selectTimout = $timeAfter if $timeAfter < $selectTimout; # si la valeur de timout est negative : c'est un after sinon # c'est un repeat - $afterList{++$afterId} = [AFTER, $timeAfter, + $afterList{++$afterId} = [AFTER, $timeAfter, timeofday()+$timeAfter, $cbListRef]; return ($afterId); @@ -959,21 +961,21 @@ sub repeat ($$;$) $timeAfter /= 1000; $selectTimout = $timeAfter if $timeAfter < $selectTimout; - $afterList{++$afterId}= [REPEAT, $timeAfter, timeofday()+$timeAfter, + $afterList{++$afterId}= [REPEAT, $timeAfter, timeofday()+$timeAfter, $cbListRef]; return ($afterId); } # end repeat -############### METHODE AFTER CANCEL +############### METHODE AFTER CANCEL sub afterCancel ($;$) { # test du premier argument au cas où la fonction est # appelee de maniere objet : premier argument = class ou une instance # de classe shift if ((ref ($_[0]) eq __PACKAGE__) || ($_[0] eq __PACKAGE__)) ; - + my $id = shift; - + if (defined ($id) && defined $afterList{$id}) { if ($afterList{$id}->[1] <= $selectTimout) { delete $afterList{$id} ; @@ -1008,20 +1010,20 @@ sub afterResetTimer ($;$) } # end afterResetTimer -############### METHODE FILE EVENT +############### METHODE FILE EVENT sub fileEvent ($$;$) { # test du premier argument au cas où la fonction est # appelee de maniere objet : premier argument = class ou une instance # de classe shift if ((ref ($_[0]) eq __PACKAGE__) || ($_[0] eq __PACKAGE__)) ; - + my ($fd, $cb) = @_; - - + + unless (defined $localLoopSel) { croak ("Error in Ivy::fileEvent, Ivy should have been initialised in LOCAL loop mode\n"); - } + } if ($cb) { # adding the handler @@ -1040,7 +1042,7 @@ sub fileEvent ($$;$) ############################################################################# -############### METHODE GET BONJOUR +############### METHODE GET BONJOUR sub _getBonjour ($) { my $self = shift; @@ -1054,9 +1056,9 @@ sub _getBonjour ($) carp "Warning in Ivy::_getBonjour, recv error, Hello message discarded"; return; } - + my $addr = (unpack_sockaddr_in ($inetAddr))[1]; - + my $peerName = gethostbyaddr ($addr, AF_INET) || inet_ntoa($addr); # on force $peerPort a etre vu comme une valeur numerique @@ -1073,30 +1075,30 @@ sub _getBonjour ($) IVY_PROTOCOLE_VERSION ; return; } - + + # on verifie qu'on ne se repond pas et qu'on ne # se reconnecte pas a un process deja connecte if (exists ($self->[cnnxion]{"$addr:$peerPort"})) { #print "DBG> bonjour de $peerName:$peerPort : DEJA CONNECTE\n" ; return ; - } - else { + } else { #print "DBG> reception de $peerName : bonjour $peerPort\n" ; } - -# on verifie que l'adresse fasse partie de l'ensemble de reseau + + # on verifie que l'adresse fasse partie de l'ensemble de reseau # definis par ivybus my $addrInIvyBus = 0; - my @ivyBusAddrList = map ( (unpack_sockaddr_in ($_))[1], + my @ivyBusAddrList = map ( (unpack_sockaddr_in ($_))[1], @{$self->[broadcastBuses]}); - # Bon dans cette version on reponds aux bonjour emis par + # Bon dans cette version on reponds aux bonjour emis par # la machine locale, on ne peut donc pas avoir # une appli qui ne causerait qu'a des machines sur une # autre reseau, si ca embete qqun, qu'il me le dise push (@ivyBusAddrList, pack ("CCCC", 127,255,255,255)); push (@ivyBusAddrList, (gethostbyname (hostname()))[4]); foreach my $ivyBusAddr (@ivyBusAddrList) { - $addrInIvyBus = 1 unless (grep ($_ != 0, unpack ("CCCC", + $addrInIvyBus = 1 unless (grep ($_ != 0, unpack ("CCCC", ($addr & $ivyBusAddr) ^ $addr))); } @@ -1110,7 +1112,7 @@ sub _getBonjour ($) my $appSock = IO::Socket::INET->new (PeerAddr => $peerName, PeerPort => $peerPort, Proto => 'tcp'); - + if ($appSock) { # on cree une entree pour $appSock dans la liste des regexp $self->[cnnxion]{"$addr:$peerPort"} = 1; @@ -1142,11 +1144,11 @@ sub _getConnections ($) return; } else { -# printf "accepting connection from %s:%d\n", +# printf "accepting connection from %s:%d\n", # (gethostbyaddr ($appSock->peeraddr(),AF_INET))[0], $appSock->peerport() if $^W; } - + # callback pour traiter la reception des messages &$fileEventFunc ($appSock, [\&_getMessages, $self, $appSock]) ; @@ -1186,7 +1188,7 @@ sub _getMessages ($$) return; } - + if (length ($self->[buffByConn]{$appSock})) { $buffer = $self->[buffByConn]{$appSock} . $buffer ; $self->[buffByConn]{$appSock} = ''; @@ -1196,24 +1198,24 @@ sub _getMessages ($$) ($buffer =~ /\n$/) ; # if (defined $appSock->peername) { - $addr = $appSock->peeraddr(); + $addr = $appSock->peeraddr(); $peerPort = $appSock->peerport() ; $senderName = $self->[cnnxion]{"$addr:$peerPort"} ; $senderName = "NONAME" unless $senderName; foreach my $mess (@messages) { # print "DBG> mess from $senderName '$mess'\n"; - + # on recupere les 3 champs : le type, le numero de regexp, les valeurs - my ($type, $id, $valeurs) = $mess =~ /^(\d+) + my ($type, $id, $valeurs) = $mess =~ /^(\d+) \s+ (\d+) \002 (.*)/x ; - + # si ca a chie on rale (carp "Warning in Ivy::_getMessages, ill-formated message \'$mess\'" and return) unless defined $type ; - + # sinon on fait en fonction du type de message if ($type == MSG) { # M S G # on recupere le couple call back, regexp correspondant @@ -1224,7 +1226,7 @@ sub _getMessages ($$) # cleaning $sendername with previous \004 used for connection status if ($senderName =~ /\004(.*)/) {$senderName = $0;} - + if (ref($cb) ne 'CODE') { my $method = shift @cb; # on split sur ETX @@ -1244,7 +1246,7 @@ sub _getMessages ($$) #print "reception d'un bye\n"; $self->_removeFileDescriptor ($appSock); # B Y E } - elsif ($type == REGEXP) { # R E G E X P + elsif ($type == REGEXP) { # R E G E X P # on ajoute une fonction traitant la regexp et envoyant le # message sur le bon fd dans la liste des fonctions de filtrage # ca permet de compiler les regexp avec 'once' donc une @@ -1270,9 +1272,9 @@ sub _getMessages ($$) } }; _EOL_ - } + } else { - # l'id de la regexp etait deja utilise, + # l'id de la regexp etait deja utilise, # et n'a pas ete libere par un message delregexp, # on renvoie donc un message d'erreur $self->_sendErrorTo($appSock, "ID $id deja utilisee"); @@ -1313,7 +1315,7 @@ _EOL_ my $host = (gethostbyaddr ($addr, AF_INET))[0] || inet_ntoa($addr); $self->_scanConnStatus ($senderName, "new", "$host"); } - elsif ($type == APP_NAME) { + elsif ($type == APP_NAME) { # etat Connecte if (($self->[appName] eq $valeurs) && $^W) { carp "\033[1mWarning in Ivy::_getMessages, there is already an instance of ". @@ -1321,7 +1323,7 @@ _EOL_ } $senderName = $valeurs; - $self->[cnnxion]{"$addr:$peerPort"} = "\004$valeurs"; + $self->[cnnxion]{"$addr:$peerPort"} = "\004$valeurs"; } elsif ($type == DIRECT_MSG) { @@ -1372,19 +1374,19 @@ _EOL_ warn ("Warning in Ivy::_getMessages, received a message of unknown ". " type $type from $senderName :\n\"$mess\""); } - } + } return 0; } # end _getMessages -############### METHODE SEND WANTED REGEXP +############### METHODE SEND WANTED REGEXP sub _sendWantedRegexp ($$) { my ($self, $appSock) = @_; - + # on envoie le message "Nom appli" send ($appSock, sprintf (MSG_FMT, APP_NAME, 0, $self->[appName]), 0) or $self->_removeFileDescriptor ($appSock) ; - + # on envoie les regexps for (my $id = 0; $id <= $#{$self->[recCbList]}; $id++) { next unless defined $self->[recCbList][$id]->[1]->[0]; @@ -1392,11 +1394,11 @@ sub _sendWantedRegexp ($$) send ($appSock, sprintf (MSG_FMT, REGEXP, $id, $self->[recCbList][$id]->[0]), 0) or $self->_removeFileDescriptor ($appSock) ; - # print sprintf ("DBG> %s %d %s\n", + # print sprintf ("DBG> %s %d %s\n", # 'REGEXP', $id, $self->[recCbList][$id]->[0]); } # on envoie le message de fin d'envoi de regexps - send ($appSock, sprintf (MSG_FMT, ENDREGEXP, 0, ""), 0) + send ($appSock, sprintf (MSG_FMT, ENDREGEXP, 0, ""), 0) or $self->_removeFileDescriptor ($appSock) ; } # end _sendWantedRegexp @@ -1404,9 +1406,9 @@ sub _sendWantedRegexp ($$) sub _sendLastRegexpToAllreadyConnected ($$) { my ($self, $id) = @_; - + foreach my $fd (values %{$self->[sockList]}) { - send ($fd, sprintf (MSG_FMT, REGEXP, $id, $self->[recCbList][$id]->[0]), + send ($fd, sprintf (MSG_FMT, REGEXP, $id, $self->[recCbList][$id]->[0]), 0) or $self->_removeFileDescriptor ($fd) ; } } # end _sendLastRegexpToAllreadyConnected @@ -1415,10 +1417,10 @@ sub _sendLastRegexpToAllreadyConnected ($$) sub _inetAdrByName ($$) { my ($self, $appName) = @_; - + my $addrInet = (grep ($self->[cnnxion]{$_} eq $appName, keys %{$self->[cnnxion]}))[0]; - + return ("unknow") unless defined $addrInet; my ($addr,$port) = $addrInet =~ /(.{4}):(.*)/; @@ -1431,13 +1433,13 @@ sub _inetAdrByName ($$) { sub _removeFileDescriptor ($$) { my ($self, $fd) = @_; - + my $diedAppName; - + # on s'est deja occupe de lui return unless exists $self->[sockList]->{$fd}; # printf ("DBG> _removeFileDescriptor IN thread %s\n", ${Thread->self}); - + # on efface les structures de donnees associees au fd # on vire ce fd des fd a scruter dans la bcle d'evenements # uniquement si on est dans le thread principal @@ -1446,9 +1448,9 @@ sub _removeFileDescriptor ($$) delete $self->[sendRegList]{$fd}; delete $self->[sockList]{$fd}; delete $self->[buffByConn]->{$fd}; - + $fd->close(); - + EXT_LOOP: foreach my $name (keys %{$self->[appliList]}) { foreach my $fdp (@{$self->[appliList]{$name}}) { @@ -1463,28 +1465,28 @@ sub _removeFileDescriptor ($$) } } } - + unless (defined $diedAppName) { warn "Ivy::__removeFileDescriptor : disconnection of NONAME\n" if $^W; return; } - + my $addrInet = (grep ($self->[cnnxion]{$_} eq $diedAppName, keys %{$self->[cnnxion]}))[0]; - + unless (defined $addrInet) { croak "Error in Ivy::_removeFileDescriptor, disconnection of $diedAppName with ". "addrInet not defined\n"; return; } - + #printf "DBG> _removeFileDescriptor : deconnection de %s ($diedAppName)\n", _inetAdrByName ($diedAppName); delete $self->[cnnxion]{$addrInet}; - + # on vire l'entree correspondant a ce canal dans la liste des # regexps par canal - + my $addr = substr ($addrInet,0,4); my $host = (gethostbyaddr ($addr, AF_INET))[0] || inet_ntoa($addr); $self->_scanConnStatus ($diedAppName, "died", $host) ; @@ -1495,8 +1497,8 @@ sub _removeFileDescriptor ($$) sub _sendErrorTo ($$$) { my ($self, $fd, $error) = @_; - - send ($fd, join (' ', ERROR, "0\002$error\n"), 0) + + send ($fd, join (' ', ERROR, "0\002$error\n"), 0) or $self->_removeFileDescriptor ($fd); } # end _sendErrorTo @@ -1506,7 +1508,7 @@ sub _pong ($$) { my ($self, $fd) = @_; - send ($fd, join (' ', PONG, "0\002 \n"), 0) + send ($fd, join (' ', PONG, "0\002 \n"), 0) or $self->_removeFileDescriptor ($fd); } # end _pong @@ -1515,8 +1517,8 @@ sub _pong ($$) sub _sendDieTo ($$) { my ($self, $fd) = @_; - - send ($fd, join (' ', DIE, "0\002\n"), 0) + + send ($fd, join (' ', DIE, "0\002\n"), 0) or $self->_removeFileDescriptor ($fd); } # end _sendDieTo @@ -1533,11 +1535,11 @@ sub _sendMsgTo ($$$) } # end _sendMsgTo -############### PROCEDURE TK FILE EVENT +############### PROCEDURE TK FILE EVENT sub _tkFileEvent ($$) { my ($fd, $cb) = @_; - + Tk::fileevent ('', $fd, 'readable', $cb) ; } # end _tkFileEvent @@ -1563,7 +1565,7 @@ sub _scanAfter () if ($af->[0]) { $af->[2] = $stamp + $af->[1] ; $selectTimout = $af->[1] if $af->[1] < $selectTimout; - } + } else { # si c'est un after on le vire afterCancel ($afk); @@ -1577,7 +1579,7 @@ sub _scanAfter () } # end _scanAfter -############### METHODE SCAN CONN STATUS +############### METHODE SCAN CONN STATUS sub _scanConnStatus ($$$$) { my ($self, $appname, $status, $addr) = @_; @@ -1588,11 +1590,11 @@ sub _scanConnStatus ($$$$) next if $_ eq "1"; $readyApp{$_}++ unless /^\004/; # connecte mais pas ready } - + foreach (@{$self->[neededApp]}) { push (@nonReadyApp, $_) unless exists $readyApp{$_}; } - + # par compatibilite avec l'ancienne version, on envoie comme # deux premiers arguments une ref sur la liste des applis presentes, # une ref de la liste des applis absentes, mais on rajoute comme troisieme @@ -1614,28 +1616,28 @@ sub _toBePruned ($$$) my ($self, $from, $regexp) = @_; # for message purposes, removing the \004 which indicates the connection status - + my ($cleaned_from) = $from =~ /\004?(.*)/ ; # print "DBG> $from s'abonne à nouvelle regexp '$regexp'\n"; - + # testing the received regexp for avoiding illformed regexp eval {my $test = "a" =~ /$regexp/ } ; if ($@) { warn "Warning in Ivy::_toBePruned, receiving ill-formed regexp: '$regexp' from '$cleaned_from'" ; return 1}; - + &_scanConnStatus ($self, $cleaned_from, 'subscribing', $regexp); - + # si il n'y a pas de liste de sujets, on ne # filtre pas return 0 unless @{$self->[topicRegexps]}; - + unless ($regexp =~ /^\^/) { #print "DBG> regexp non ANCREE de $from : $regexp\n"; return (0); } - + if ($regexp =~ /^\^(\w+)/) { my $topic = $1; if (grep (/$topic/, @{$self->[topicRegexps]})) { @@ -1643,7 +1645,7 @@ sub _toBePruned ($$$) #print "DBG> on garde de $from : $regexp\n"; return (0); } - #print "DBG> on ELIMINE de $from : $regexp\n"; + #print "DBG> on ELIMINE de $from : $regexp\n"; return (1); } else { @@ -1661,7 +1663,7 @@ sub _parseIvyBusParam ($) my ($ivyNetworks, $ivyPort) = $ivyBus =~ /^(.*):(.*)/; my $useMulticast = 0; - + croak ("Error in Ivy::_parseIvyBusParam, illegal bus address format: $ivyBus\n") unless $ivyPort =~ /^\d+$/; @@ -1671,7 +1673,7 @@ sub _parseIvyBusParam ($) my @broadcastAddrs = split (',', $ivyNetworks); foreach my $netAddr (@broadcastAddrs) { - $netAddr = BROADCAST_ADDRS if + $netAddr = BROADCAST_ADDRS if (($netAddr eq '') || ($netAddr =~ /^127/) || ($netAddr =~ /^loopback/)); # deux cas de figure : on a un nom de sous reseau, ou @@ -1699,11 +1701,11 @@ sub _parseIvyBusParam ($) while (!$dummyNetAddr[0]) { # tant que le premier octet est 0, on decale vers la gauche et # ont fait rentrer un 255 sur la droite - shift @dummyNetAddr; + shift @dummyNetAddr; push (@dummyNetAddr, 255); - } + } $netAddrInet = pack ("CCCC", @dummyNetAddr); - } else { + } else { # on a deja une adresse ip, on rajoute les .255 # a la fin s'ils ont ete omis. ($netAddr .= ".255.255.255") =~ s/^((\d+\.){3}\d+).*/$1/; @@ -1740,7 +1742,7 @@ sub _parseIvyBusParam ($) return ($useMulticast, $ivyPort, \@ivyAddrInet); } # end _parseIvyBusParam - + ############# Procedure _SUBSTITUTE ESCAPED CHAR sub _substituteEscapedChar ($$) { @@ -1749,7 +1751,7 @@ sub _substituteEscapedChar ($$) my %escapeRegexp = REG_PERLISSISME; # Si on fait la substitution dans une classe de caractere # on elimine les crochets. - grep ($escapeRegexp{$_} =~ s/[\[\]]//g, keys %escapeRegexp) + grep ($escapeRegexp{$_} =~ s/[\[\]]//g, keys %escapeRegexp) if ($scope eq 'inside') ; $reg =~ s/\\([wWsSdDne])/$escapeRegexp{$1}/ge; @@ -1809,7 +1811,7 @@ Name of your application used to identify on ivy bus. A list of domains (may be empty), followed by a port number where to broadcast messages. If the domain list is empty (i.e. parameter is ':port number'), broadcast will be done on localhost (i.e. '127:port number'). Default is the value of the environment variable -IVYBUS and if it is not defined the default is 127:2010. +IVYBUS and if it is not defined the default is 127:2010. Since V4.12, it is possible to use multicast (ie. with a domain between 224.0.0.0 and 239.255.255.255). You must be aware than when multicast is used, udp broadcast (defined in the B<-ivyBus> paramter) are skipped. You should also probably avoid using the 244.x.x.x domain often used for networking management. @@ -2012,7 +2014,7 @@ This allows you to bind a regular expression to a callback or method. The callback or method will be called for every message that matches the regexp (case insensitive). See perlre(1) to find how to write regexps. -Use the bracketing construct ( ... ) so that your callback is +Use the bracketing construct ( ... ) so that your callback is called with the captured bits of text as parameters. To unbind callback(s) associated to a regexp use bindRegexp with only one argument, the regexp. Note that doing the same binding more than |