# # Ivy, Perl interface # # Copyright 1997-2002 # Centre d'Études de la Navigation Aérienne # # Authors: Alexandre Bustico # Stéphane Chatty # Hervé Damiano # Christophe Mertz # # All functions # # $Id$ # # This program is free software; you can redistribute it and/or # 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 ; use Sys::Hostname; use IO::Socket; use strict; use Time::Gettimeofday; use vars qw($VERSION); # 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_]+)/ ; if (defined $VERSION and $VERSION ne "_") { $VERSION =~ s/_/\./g; } else { $VERSION = $REVISION; } ############################################################################# #### PROTOTYPES ##### ############################################################################# sub init; # methode de classe, permet de renseigner # tous les parametres globaux. Ces parametres # seront utilises par new si ils ne sont pas # donnes lors de l'appel de new. sub new ($%); # verifie la validite de tous les parametres, # cree et retourne un objet Ivy. Les parametres # appName, networks, messWhenReady, peuvent # etre donnes, meme si ils ont deja ete # donnes dans init, dans ce cas, ce sont ceux # de new qui prevalent sub start; # debut de l'integration au bus : # - 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 # traiter les bonjours # - 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 # ou d'annuler une precedente association 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 sub sendDirectMsgs; # envoie une liste de messages directs a une appli sub sendDieTo; # envoie un <> 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 # 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 # sera execute. # par contre si on est en mainloop Tk, # il faut en plus detruire la mainwindow # pour sortir de la mainloop; sub after ($$;$); # temps en millisecondes, callback sub repeat ($$;$); # temps en millisecondes, callback sub afterCancel ($;$); # l'id d'un cancel ou d'un repeat sub afterResetTimer ($;$); # pour ré-armer un timer non-encore déclenché à sa valeur initiale sub fileEvent ($$;$); # associe un fd a un callback pour la mainloop locale ################ PRIVEE #################################################### sub _getBonjour ($); # lit le (ou les) bonjour(s) sur le canal de supervision # et se connecte, verifie qu'il ne se reponds pas lui # meme, ni qu'il ne repond pas a un service deja connecte sub _getConnections ($); # est appele lors d'une demande de connection : # accepte la connection et mets a jour @sendRegList # rajoute le fd du canal aux fd a scruter dans la # boucle d'evenements sub _getMessages ($$); # est appele lorqu'un message arrive sub _sendWantedRegexp ($$); # envoie les regexp a l'appli distante sub _sendLastRegexpToAllreadyConnected ($$) ; # envoie la derniere regexp # pushee dans @recCbList # 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 sub _sendDieTo ($$); #(fd) envoie un message de demande de suicide a un fd sub _sendMsgTo ($$$); # (fd, message) 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 # $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 # liste d'adresses addr_inet sub _substituteEscapedChar ($$); #permet de transformer une regexp etendue # 'perl' en regexp de base ############################################################################# #### CONSTANTES ##### ############################################################################# use constant MSG_FMT => "%d %d\002%s\n"; # par defaut, on diffuse le bonjour en local use constant BROADCAST_ADDRS => "127.255.255.255" ; use constant BROADCAST_PORT => "2010"; use constant BYE => 0; use constant REGEXP => 1; use constant MSG => 2; use constant ERROR => 3; use constant DELREGEXP => 4; use constant ENDREGEXP => 5; use constant APP_NAME => 6; use constant DIRECT_MSG => 7; use constant DIE => 8; use constant PING => 9; use constant PONG => 10; use constant IVY_PROTOCOLE_VERSION => 3; use constant AFTER => 0; use constant REPEAT => 1; use constant MAX_TIMOUT => 1000; # pour pouvoir employer les regexps perl. Attention lors de l'utilisation # ne pas mettre un \n dans une chaine entre "" car l'\n sera interprete. use constant REG_PERLISSISME => ('w' => '[a-zA-Z0-9_]', 'W' => '[^a-zA-Z0-9_]', 's' => "[\t ]", 'S' => "[^\t ]", 'd' => '[0-9]', 'D' => '[^0-9]', 'n' => '', # Il ne faut pas mettre d'\n : # c'est un delimiteur pour le bus 'e' => '[]') ; ############################################################################# #### VARIABLES de CLASSE ##### ############################################################################# # l'objet Ivy utilise par defaut quand le programmeur # utilise le mode de compatibilite de la version 3, et ne # manipule pas d'objets my $globalIvy ; # optimisation : si l'on connait les sujets des messages # qu'on envoie, cette variable contient une liste de # sujets qui doivent matcher les regexps d'abonnement # pour que celle ci se soient pas eliminees my @topicRegexps; # 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 : 127.255.255.255 # c.a.d local a la machine my $ivyBus ; # le nom de l'appli pour le bus my $appName ; # message a envoyer a un canal lorsqu'on # a recu le message endregexp. my $messWhenReady ; # fonction de cb appelee lorsque l'appli a recu l'ordre # de quitter, on peut dans ce callback fermer # proprement les ressources avant de sortir. # ps : ne pas fasire d'exit dans le callback, # c'est le bus qui s'en charge my $onDieFunc; # permet de donner des valeurs successives aux constantes permettant # d'acceder aux differents champs de l'objet my $constantIndexer =0; # pointeur sur la fonction permettant d'associer # des callbacks a un file desc, (ainsi que de les enlever) 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; # table d'ass. handle -> callback my %localBindByHandle; # tableau d'ass [AFTER ou REPEAT, # timeTotal, deadLine, [callback, arg, arg, ...]] my %afterList=(); my $afterId = 0; # timeout le plus petit pour le select my $selectTimout = MAX_TIMOUT; # liste des bus actifs my %allBuses = (); ############################################################################# #### CLEFS DES VARIABLES D'INSTANCE ##### #### ##### #### l'objet Ivy sera 'blessed' sur une reference sur un array et non ##### #### sur une table de hash comme pratique courament de facon a ##### #### 1/ optimiser au niveau vitesse ##### #### 2/ avoir des clefs sous forme de symboles (use constant...) ##### #### et nom des clefs sous forme de chaines de caracteres ##### #### de facon a eviter des erreurs ##### #### ##### #### ##### ############################################################################# use constant servPort => $constantIndexer++; use constant neededApp => $constantIndexer++; use constant statusFunc => $constantIndexer++; use constant supSock => $constantIndexer++; use constant connSock => $constantIndexer++; use constant sockList => $constantIndexer++; use constant threadList => $constantIndexer++; use constant appliList => $constantIndexer++; use constant sendRegList => $constantIndexer++; use constant sendRegListSrc => $constantIndexer++; use constant topicRegexps => $constantIndexer++; use constant recCbList => $constantIndexer++; use constant directCbList => $constantIndexer++; use constant cnnxion => $constantIndexer++; use constant buffByConn => $constantIndexer++; use constant broadcastPort => $constantIndexer++; use constant broadcastBuses => $constantIndexer++; use constant appName => $constantIndexer++; use constant messWhenReady => $constantIndexer++; ############################################################################# #### METHODES PUBLIQUES ##### ############################################################################# sub init { my $class = shift if (@_ and $_[0] eq __PACKAGE__); my (%options) = @_; # valeurs par defaut pour le parametre : variable d'environnement # ou valeur cablee, a defaut my $default_ivyBus = defined $ENV{"IVYBUS"} ? $ENV{"IVYBUS"} : BROADCAST_ADDRS.':'.BROADCAST_PORT; my %optionsAndDefaults = ( #PARAMETRES OBLIGATOIRES -loopMode => undef, # TK ou LOCAL -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 : # 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 # proprement les ressources avant de sortir. # ps : ne pas fasire d'exit dans le callback, # c'est le bus qui s'en charge -pruneRegexp => [], # 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. ) ; # on examine toutes les options possibles foreach my $opt (keys %optionsAndDefaults) { # si un parametre a ete fourni, ignorer les valeurs par defaut next if defined $options{$opt} ; # sinon, prendre la valeur par defaut si elle existe if (defined $optionsAndDefaults{$opt}) { $options{$opt} = $optionsAndDefaults{$opt} ; # sinon, on jette l'eponge } else { die "Error in Ivy::init: option $opt is mandatory\n"; } } # on examine toutes les options fournies, pour detecter les inutiles foreach my $opt (keys %options) { unless (exists ($optionsAndDefaults{$opt})) { warn "Warning in Ivy::init: option $opt is unknown\n"; } } my $loopMode = $options{-loopMode}; $ivyBus = $options{-ivyBus}; $appName = $options{-appName} ; $onDieFunc = $options{-onDieFunc} ; @topicRegexps = @{$options{-pruneRegexp}}; $messWhenReady = $options{-messWhenReady} eq "_APP NAME READY" ? "$appName READY" : $options{-messWhenReady}; if ($loopMode =~ /local/i) { # mode boucle d'evenement locale use IO::Select; $fileEventFunc = \&fileEvent ; $localLoopSel = IO::Select->new (); } elsif ($loopMode =~ /tk/i) { # mode boucle d'evenement de TK $fileEventFunc = \&_tkFileEvent ; } else { die "Error in Ivy::init, argument loopMode must be either TK or LOCAL\n"; } $SIG{'PIPE'} = 'IGNORE' ; } ############# METHODE DE CLASSE NEW sub new ($%) { 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 unless ((defined $appName) && ($appName ne '')) { die "Error in Ivy::new, you should have called Ivy->init () first."; } # No de port tcp du serveur $self->[servPort] = ''; # liste des applis necessaires a l'appli locale $self->[neededApp] = []; # callback prenant en param 3 refs sur des listes : # [applis presentes, appli absentes, hash_applis_present] # cette fonction est appelee : # - tout les pollingTime tant que toutes les applis # ne sont pas presentes # - des qu'une appli se connecte # - lorsqu'une appli se deconnecte $self->[statusFunc] = ''; # callback prenant en param 1 refs sur une liste : # [ref sur fonction, parametres] # socket de supervision en lecture/ecriture $self->[supSock] = ''; # socket de connexion tcp $self->[connSock] = ''; # tab ass : nom du fd => fd $self->[sockList] = {}; # tab ass : nom de l'appli => fd $self->[appliList] = {}; # tableau ass de liste du type # sockId => [fonction, fonction, ...] # pour savoir quoi envoyer a qui # les fonctions anonymes sont compilees # dynamiquement a la reception des messages REGEXP # et filtrent les mess a envoyer et les envoient # au besoin $self->[sendRegList] = {}; # tableau ass de liste du type # sockId => "regexp" # pour connaitre la valeur des regexp meme apres compilation $self->[sendRegListSrc] = {}; # liste des topics qu'on envoie si on # filtre les regexps $self->[topicRegexps] = []; # liste de ref sur des couples # (regexp,callBack) les callbacks # sont appeles lors de # la reception de messages en fonction # du numero de regexp. $self->[recCbList] = []; # liste de callBack pour les messages directs $self->[directCbList] = []; # tableau ass : clef = nom:numero_de port # permet de verifier qu'on ne se connecte pas # sur nous meme et qu'on ne se reconnecte # pas sur un service en cas de bonjours repetes # valeur : nom de l'application $self->[cnnxion] = {}; # tableau associatif, clef => file desc, # valeur :buffer au cas ou la lecture ne se termine # pas par \n, de maniere a resegmenter les messages $self->[buffByConn] = {}; 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 : # 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 # presentes, et si une appli necessaire se deconnecte # les trois parametres passes sont : # [liste des applis presentes], # [liste des applis absentes], # [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 # tourne sur le meme bus : danger !! -pruneRegexp => [@topicRegexps], # 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. ) ; # on examine toutes les options possibles foreach my $opt (keys %optionsAndDefaults) { # si un parametre a ete fourni, ignorer les valeurs par defaut next if defined $options{$opt} ; # sinon, prendre la valeur par defaut si elle existe if (defined $optionsAndDefaults{$opt}) { $options{$opt} = $optionsAndDefaults{$opt} ; # sinon, on jette l'eponge } else { die "Error in Ivy::new: option $opt is mandatory\n"; } } # on examine toutes les options fournies, pour detecter les inutiles foreach my $opt (keys %options) { unless (exists ($optionsAndDefaults{$opt})) { warn "Warning in Ivy::new, option $opt is unknown\n"; } } $self->[appName] = $options{-appName} ; $self->[messWhenReady] = $options{-messWhenReady} ; @{$self->[neededApp]} = @{$options{-neededApp}} ; $self->[statusFunc] = $options{-statusFunc} ; $self->[topicRegexps] = $options{-pruneRegexp} ; $allBuses{$self} = $self; ($self->[broadcastPort], $self->[broadcastBuses]) = _parseIvyBusParam ($options{-ivyBus}); return ($self); } ############### METHODE IVY DESTROY sub DESTROY ($) { my $self = shift; return unless exists $allBuses{$self}; # print ("DBG DESTROY appele sur l'objet $self\n"); # pour toutes les connections foreach my $fd (values %{$self->[sockList]}) { # 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 DONOT work with ivy-c api. # the 2 next lines works. This has to been validated! CM 21/12/2000 send ($fd, sprintf (MSG_FMT, BYE, 0, ""), 0); $self->_removeFileDescriptor ($fd); } # on clot la socket de signalisation (UDP) # print "DBG> fermeture de supSock\n"; $self->[supSock]->close() if $self->[supSock]; delete $allBuses{$self}; # on clot la socket de connection # print "DBG> fermeture de connSock\n"; $self->[connSock]->close() if $self->[connSock]; undef (@$self); } ############### METHODE DE CLASSE STOP sub stop () { foreach my $bus (values %allBuses) { $bus->DESTROY(); } # pour toutes les connections } ############## METHODE DE CLASSE EXIT sub exit () { Ivy::stop (); if (defined $localLoopSel) { # boucle locale, on sait faire # printf ("DBG> undefining localLoopSel\n"); undef $localLoopSel; } else { Tk::exit (); } } ############### PROCEDURE BUS START sub start { my $self; # compatibility for version 3 interface, ie. no objects manipulated by programmer if (not @_ or ref ($_[0]) ne __PACKAGE__) { init (@_); $self = $globalIvy = new Ivy; } else { $self = shift; } if ($self->[connSock]) { print "*** the Ivy bus is already started\n"; return; } # cree la socket de connexion, recupere le no de port my $connSock = $self->[connSock] = IO::Socket::INET->new(Listen => 128, Proto => 'tcp', Reuse => 1) ; # 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 $localhostAddr = (gethostbyname ('localhost'))[4] ; $self->[cnnxion]->{"$hostAddr:". $connSock->sockport} = "\004"; $self->[cnnxion]->{"$localhostAddr:". $connSock->sockport} = "\004"; # cree la socket de broadcast $self->[supSock] = IO::Socket::INET->new (LocalPort => $self->[broadcastPort], Proto => 'udp', Type => SOCK_DGRAM, Reuse => 1); $self->[supSock]->sockopt (SO_BROADCAST, 1); # et on envoie envoie le bonjour : "no de version no de port" my $bonjourMsg = sprintf ("%d %d\n", IVY_PROTOCOLE_VERSION, $connSock->sockport()); foreach my $netBroadcastAddr (@{$self->[broadcastBuses]}) { send ($self->[supSock], $bonjourMsg, 0, $netBroadcastAddr) or warn "Warning in Ivy::start, broadcast of Hello message failed: $!\n"; } # 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; } ############### PROCEDURE BIND REGEXP sub bindRegexp { my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy; my ($regexp, $cb) = @_; my $original_regexp = $regexp; # on substitue les meta caracteres des regexps perl : \d, \w, \s, \e # par les classes de caracteres corespondantes de maniere a ce # qu'une appli distante non perl comprenne ces regexp. $regexp =~ s| ( (?[recCbList]}+1); $id++) { last unless (defined $self->[recCbList][$id]) && @{$self->[recCbList][$id]->[1]}; } $self->[recCbList][$id] = [$regexp, $cb]; # on envoie les messages regexps aux processus deja connectes _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); } } } } } ############### 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 $self->[directCbList][$id] = $cb; } else { # on vire le callback undef $self->[directCbList][$id]; } } ############### PROCEDURE SEND MSGS sub sendMsgs { my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy; my @msgs = @_; my $total = 0; # pour tous les messages foreach my $msg (@msgs) { warn "Warning in Ivy::sendMsgs, a message contains a '\\n'. Skipping it:\n'$msg'\n" if ($msg =~ /\n/); study ($msg); # pour routes les connections foreach my $fd (keys %{$self->[sockList]}) { # pour toutes les fonctions de filtrage de regexp foreach my $regexpFunc (@{$self->[sendRegList]{$fd}}) { $total += &{$regexpFunc} (\$msg) if defined $regexpFunc; } } } # print "DBG> sended $total times\n"; return $total; } ############### PROCEDURE SEND MSGS sub sendAppNameMsgs { my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy; my @msgs = @_; my $total = 0; # pour tous les messages foreach (@msgs) { warn "Warning in Ivy::sendAppNameMsgs, a message contains a '\\n'. Skipping it:\n'$_'\n" if ($_ =~ /\n/); my $msg = "$self->[appName] $_"; study ($msg); # pour routes les connections foreach my $fd (keys %{$self->[sockList]}) { # pour toutes les fonctions de filtrage de regexp foreach my $regexpFunc (@{$self->[sendRegList]{$fd}}) { $total += &{$regexpFunc} (\$msg) if defined $regexpFunc; } } } # print "DBG> sended $total times\n"; return $total; } ############### PROCEDURE SEND DIRECT MSGS sub sendDirectMsgs { my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy; my ($to, $id, @msgs) = @_; if (defined ($self->[appliList]{$to})) { my @fds = @{$self->[appliList]{$to}}; # pour tous les messages foreach my $msg (@msgs) { warn "Warning in Ivy::sendDirectMsgs, a message contains a '\\n'. Skipping it:\n'$msg'\n" if ($msg =~ /\n/); foreach my $fd (@fds) { send ($fd, sprintf (MSG_FMT, DIRECT_MSG, $id, "$msg"), 0) or $self->_removeFileDescriptor ($fd); } } return 1; } else { warn "Warning in Ivy::sendDirectMsgs, application $to unknown\n"; return 0; } } ############### METHOD SEND DIE TO sub sendDieTo { my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy; my ($to) = @_; if (defined ($self->[appliList]{$to})) { my @fds = @{$self->[appliList]{$to}}; warn "Attention : Ivy::sendDieTo gros BUG \@fds est vide \n" if (scalar (@fds) == 0); # pour tous les messages foreach my $fd (@fds) { $self->_sendDieTo($fd); } return 1; } else { warn "Warning in Ivy::sendDieTo, application $to is unknown\n" if $^W; return 0; } } ############### METHOD PING sub ping { my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy; my ($to, $timeout) = @_; if (defined ($self->[appliList]{$to})) { my @fds = @{$self->[appliList]{$to}}; # pour tous les messages foreach my $fd (@fds) { send ($fd, sprintf (MSG_FMT, PING, 0, " "), 0) or $self->_removeFileDescriptor ($fd); } } } ############### METHODE MAINLOOP sub mainLoop () { die "Error in Ivy::mainLoop, Ivy should have been initialised with LOCAL loop mode \n" unless defined $localLoopSel; my ($fd, @ready, @allDesc); while (defined $localLoopSel) { @ready = IO::Select::can_read ($localLoopSel, $selectTimout) ; _scanAfter () ; foreach my $fd (@ready) { if (ref $localBindByHandle{$fd} eq 'CODE') { &{$localBindByHandle{$fd}} ; } else { my ($cb, @arg) = @{$localBindByHandle{$fd}} ; &$cb (@arg) } } } } ############### METHODE AFTER sub after ($$;$) { # 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 ($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, timeofday()+$timeAfter, $cbListRef]; return ($afterId); } ############### METHODE REPEAT sub repeat ($$;$) { # 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__)) ; # on passe le temps en secondes pour le select my ($timeAfter, $cbListRef) = @_; $timeAfter /= 1000; $selectTimout = $timeAfter if $timeAfter < $selectTimout; $afterList{++$afterId}= [REPEAT, $timeAfter, timeofday()+$timeAfter, $cbListRef]; return ($afterId); } ############### 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} ; # le timout de l'after/repeat etait le plus petit des timout # on cherche donc le plus petit parmi ceux qui restent; $selectTimout = MAX_TIMOUT; foreach my $af (values %afterList) { $selectTimout = $af->[1] if $af->[1] < $selectTimout ; } } else { delete $afterList{$id} ; } } } ############### METHODE AFTER RESET TIMER # permet de gérer des timout plus facilement en permettant de # réarmer un after non encore déclenché à sa valeur initiale # cela évite le aftercancel suivi d'un nouvel after sub afterResetTimer ($;$) { # 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}) { $afterList{$id}->[2] = $afterList{$id}->[1] + timeofday(); } } ############### 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) { die ("Error in Ivy::fileEvent, Ivy should have been initialised in LOCAL loop mode\n"); } if ($cb) { # adding the handler $localBindByHandle{$fd} = $cb; $localLoopSel->add ($fd); } else { # deleting the handler delete $localBindByHandle{$fd}; # print ("DBG: Ivy::fileEvent : removing fd from the select\n"); $localLoopSel->remove ($fd); } } ############################################################################# #### METHODES PRIVEES ##### ############################################################################# ############### METHODE GET BONJOUR sub _getBonjour ($) { my $self = shift; my $bonjourMsg = ''; # l'hote distant my $inetAddr = $self->[supSock]->recv ($bonjourMsg, 1024, 0); unless (length $inetAddr) { warn "Warning in Ivy::_getBonjour, recv error, Hello message discarded\n"; return; } my $addr = (unpack_sockaddr_in ($inetAddr))[1]; my $peerName = gethostbyaddr ($addr, AF_INET); # on force $peerPort a etre vu comme une valeur numerique my ($version, $peerPort) = $bonjourMsg =~ /^(\d+)\s+(\d+)/; unless (defined ($version) && defined ($peerPort)) { warn "Warning in Ivy::_getBonjour, ill-formed Hello message \"$bonjourMsg\"\n" ; return; } if ($version != IVY_PROTOCOLE_VERSION) { warn "Warning in Ivy::_getBonjour, connection request from ". "$peerName with protocol version $version,\ncurrent version is " . IVY_PROTOCOLE_VERSION . "\n" ; 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 { #print "DBG> : reception de $peerName : bonjour $peerPort\n" ; } # 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], @{$self->[broadcastBuses]}); # 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", ($addr & $ivyBusAddr) ^ $addr))); } if ($addrInIvyBus == 0) { warn "Warning: Hello message from $peerName ignored,\n". "this guy is outside our emission zone\n" if $^W; return; } # ouverture du canal de communication 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; $self->[sendRegList]{$appSock} = []; $self->[sendRegListSrc]{$appSock} = []; $self->[buffByConn]{$appSock} = ''; $self->[sockList]{$appSock} = $appSock; &$fileEventFunc ($appSock, [\&_getMessages, $self, $appSock]) ; # on balance les regexps qui nous interessent a l'appli distante $self->_sendWantedRegexp ($appSock); } else { warn "Warning in Ivy::_getBonjour, connection to " . "$peerName:$peerPort is impossible\n" ; } } ############### PROCEDURE GET CONNECTIONS sub _getConnections ($) { my $self = shift; my $appSock = $self->[connSock]->accept(); unless (defined $appSock) { warn "Warning in Ivy::_getConnections, \$appSock not defined\n"; return; } else { # 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]) ; # on cree une entree pour $appSock dans la liste des regexp $self->[sendRegList]{$appSock} = []; $self->[sendRegListSrc]{$appSock} = []; $self->[buffByConn]{$appSock} = ''; $self->[sockList]{$appSock} = $appSock; # on balance les regexps qui nous interessent a l'appli distante $self->_sendWantedRegexp ($appSock); } ############### METHODE GET MESSAGES sub _getMessages ($$) { my ($self, $appSock) = @_; my $mess; my $buffer = ''; my ($addr, $peerPort, $senderName); # on recupere le message recv ($appSock, $buffer, 65536, 0) ; unless (length $buffer) { # message null : broken pipe, ça s'est deconnecte a l'autre bout # on vire ce fd de la boucle d'evenements # print ("DBG : _getMessages, recv err, calling removeFileDesc.\n"); # Bon la il faudra un jour clarifier ce bordel, lister toutes # les facons dont un couple d'applis connectee peuevent sortir et # eviter les dead lock qui doivent subsister. if (defined ($localLoopSel)) { $self->_removeFileDescriptor ($appSock); } else { $self->_removeFileDescriptor ($appSock); } return; } if (length ($self->[buffByConn]{$appSock})) { $buffer = $self->[buffByConn]{$appSock} . $buffer ; $self->[buffByConn]{$appSock} = ''; } my @messages = split ('\n', $buffer) ; $self->[buffByConn]{$appSock} = pop (@messages) unless ($buffer =~ /\n$/) ; # if (defined $appSock->peername) { $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+) \s+ (\d+) \002 (.*)/x ; # si ca a chie on rale (warn "Warning in Ivy::_getMessages, ill-formated message $mess\n" 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 # a l'identifiant et on appelle la fonction avec les parametres # traites par la regexp if (my @cb = @{$self->[recCbList][$id]->[1]}) { my $cb = shift @cb; my $refcb = ref($cb); # cleaning $sendername with previous \004 used for connection status if ($senderName =~ /\004(.*)/) {$senderName = $0;} if ($refcb ne 'CODE') { my $method = shift @cb; # on split sur ETX $cb->$method($senderName, @cb, split ("\003", $valeurs)) ; } else { &$cb ($senderName, @cb, split ("\003", $valeurs)) ; } } else { #_sendErrorTo ($appSock, "REEGXP ID $id inconnue"); warn ("Warning in Ivy::_getMessages, received an unknown message ". "with id $id from $senderName :\n\"$mess\""); } } elsif ($type == BYE) { #print "reception d'un bye\n"; $self->_removeFileDescriptor ($appSock); # B Y E } 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 # fois pour toute, et ainsi optimiser la vitesse de # filtrage des messages a envoyer # print "DBG>REGEXP from $senderName '$id' '$valeurs'\n"; next if $self->_toBePruned ($senderName, $valeurs); unless (defined $self->[sendRegList]{$appSock}->[$id]) { # si l'id de regexp n'etait pas utilisee c'est tout bon # on affecte la nouvelle regexp a un id $self->[sendRegListSrc]{$appSock}->[$id] = $valeurs; $self->[sendRegList]{$appSock}->[$id] = eval <<'_EOL_'; sub { use strict; if (my @args = ${$_[0]} =~ /($valeurs)/io) { shift @args; $args[$#args] .= "\003" if @args; send ($appSock, sprintf (MSG_FMT, MSG, $id, join ("\003",@args)), 0) or $self->_removeFileDescriptor ($appSock) ; #print join (' ', "DBG > J'envoie MSG", $id, @args, "\n"); return 1; } }; _EOL_ } else { # 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"); } } elsif ($type == ERROR) { # E R R O R warn ("Warning in Ivy::_getMessages, error message received from ". "$senderName : \"$valeurs\"\n"); } elsif ($type == DELREGEXP) { # D E L R E G E X P # on vire la regexp des regexps verifiées $self->[sendRegList]{$appSock}->[$id] = undef ; my $regexp = $self->[sendRegListSrc]{$appSock}->[$id]; # cleaning $sendername with previous \004 used for connection status if ($senderName =~ /\004(.*)/) { $senderName = $0; } $self->[sendRegListSrc]{$appSock}->[$id] = undef; &_scanConnStatus ($self, $senderName, 'unsubscribing', $regexp); } elsif ($type == ENDREGEXP) { # E N D R E G E X P # on envoie le message ready uniquement a celui qui nous # a envoye le message endregexp $self->_sendMsgTo ($appSock, $self->[messWhenReady]); # on passe de l'etat Connecte a l'etat Ready $self->[cnnxion]{"$addr:$peerPort"} =~ s/^\004//; $senderName = $self->[cnnxion]{"$addr:$peerPort"}; unless (exists $self->[appliList]{$senderName}) { $self->[appliList]{$senderName} = [$appSock]; } else { push @{$self->[appliList]{$senderName}}, $appSock; } my $host = (gethostbyaddr ($addr, AF_INET))[0] ; $self->_scanConnStatus ($senderName, "new", "$host"); } elsif ($type == APP_NAME) { # etat Connecte if (($self->[appName] eq $valeurs) && $^W) { warn "\033[1mWarning in Ivy::_getMessages, there is already an instance of ". "$self->[appName] \033[m\n" ; } $senderName = $valeurs; $self->[cnnxion]{"$addr:$peerPort"} = "\004$valeurs"; } elsif ($type == DIRECT_MSG) { if (defined $self->[directCbList][$id]) { my @cb = @{$self->[directCbList][$id]}; my $cb = shift @cb; my $refcb = ref($cb); if ($refcb ne 'CODE') { my $method = shift @cb; $cb->$method(@cb, $valeurs); } else { &$cb (@cb, $valeurs); } } else { $self->_sendErrorTo ($appSock, "DIRECT ID $id inconnue"); warn "Warning in Ivy::_getMessages, received a DIRECT message with ". "unknown id $id from $senderName :\n\"$mess\""; } } elsif ($type == DIE) { # il faut quitter # on commence par appeler la callback de fin my @cb = @{$onDieFunc}; my $cb = shift @cb; my $refcb = ref($cb); if ($refcb ne 'CODE') { my $method = shift @cb; $cb->$method(@cb); } else { &$cb (@cb); } # on avertit les autres qu'on se barre my $adr = $self->_inetAdrByName ($senderName) ; warn "Notice in Ivy::_getMessages, received a suicide request from " . "$senderName ($adr) ... exiting\n" if $^W; # adios Ivy::exit (); } elsif ($type == PING) { # si on recois un ping, on envoie un pong $self->_pong ($appSock); } elsif ($type == PONG) { return PONG; } else { _$self->sendErrorTo ($appSock, "TYPE DE MESS $type inconnu"); warn ("Warning in Ivy::_getMessages, received a message of unknown ". " type $type from $senderName :\n\"$mess\""); } } return 0; } ############### 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]; send ($appSock, sprintf (MSG_FMT, REGEXP, $id, $self->[recCbList][$id]->[0]), 0) or $self->_removeFileDescriptor ($appSock) ; # 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) or $self->_removeFileDescriptor ($appSock) ; } ############### METHODE SEND LAST REGEXP TO ALLREADY CONNECTED sub _sendLastRegexpToAllreadyConnected ($$) { my ($self, $id) = @_; foreach my $fd (values %{$self->[sockList]}) { send ($fd, sprintf (MSG_FMT, REGEXP, $id, $self->[recCbList][$id]->[0]), 0) or $self->_removeFileDescriptor ($fd) ; } } ############### METHODE INET ADR BY NAME 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}):(.*)/; my $host = (gethostbyaddr ($addr, AF_INET))[0] ; return "$host:$port"; } ############### PROCEDURE REMOVE FILE DESCRIPTOR 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 # sinon le select merde salement sur ce coup &$fileEventFunc ($fd, '') ; 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}}) { if ($fd eq $fdp) { $diedAppName = $name; @{$self->[appliList]{$name}} = grep ($_ ne $fdp, @{$self->[appliList]{$name}}); if (scalar (@{$self->[appliList]{$name}}) == 0) { delete $self->[appliList]->{$name} } last EXT_LOOP; } } } 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) { die "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] ; $self->_scanConnStatus ($diedAppName, "died", $host) ; } ############### METHODE SEND ERROR TO sub _sendErrorTo ($$$) { my ($self, $fd, $error) = @_; send ($fd, join (' ', ERROR, "0\002$error\n"), 0) or $self->_removeFileDescriptor ($fd); } ############### METHODE PONG sub _pong ($$) { my ($self, $fd) = @_; send ($fd, join (' ', PONG, "0\002 \n"), 0) or $self->_removeFileDescriptor ($fd); } ############### METHODE SEND ERROR TO sub _sendDieTo ($$) { my ($self, $fd) = @_; send ($fd, join (' ', DIE, "0\002\n"), 0) or $self->_removeFileDescriptor ($fd); } ############### METHODE SEND MSG TO sub _sendMsgTo ($$$) { my ($self, $fd, $msg) = @_; # pour toutes les fonctions de filtrage de regexp foreach my $regexpFunc (@{$self->[sendRegList]{$fd}}) { &{$regexpFunc} (\$msg) if defined $regexpFunc; } } ############### PROCEDURE TK FILE EVENT sub _tkFileEvent ($$) { my ($fd, $cb) = @_; Tk::fileevent ('', $fd, 'readable', $cb) ; } ############### PROCEDURE SCAN AFTER sub _scanAfter () { my $stamp = timeofday (); $selectTimout = MAX_TIMOUT; foreach my $afk (keys %afterList) { my $af = $afterList{$afk}; # si ce timer est a declencher if ($af->[2] <= $stamp) { # on traite : le temps de declencher le cb est arrive if (ref $af->[3] eq 'CODE') { &{$af->[3]}; } else { my ($cb, @args) = @{$af->[3]}; &$cb (@args); } # si c'est un repeat on le reconduit 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); } } else { my $timeTotrigg = $af->[2] - $stamp; $selectTimout = $timeTotrigg if $timeTotrigg < $selectTimout; } } } ############### METHODE SCAN CONN STATUS sub _scanConnStatus ($$$$) { my ($self, $appname, $status, $addr) = @_; my (%readyApp, @nonReadyApp); foreach (values %{$self->[cnnxion]}) { 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, # la liste des applis absentes, mais on rajoute comme troisieme # argument une ref sur une table de hash : comme clef les # applis presentes, comme valeur le nombre d'applis ayant ce nom, # de facon a detecter plus facilement quand il y a trop d'applis # de meme nom sur le meme bus. &{$self->[statusFunc]} ([keys %readyApp], \@nonReadyApp, \%readyApp, $appname, $status, $addr); } ############### METHODE TO BE PRUNED 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]})) { # on a trouve ce topic : on ne filtre pas la regexp #print "DBG> on garde de $from : $regexp\n"; return (0); } #print "DBG> on ELIMINE de $from : $regexp\n"; return (1); } else { #print "DBG> on garde de $from : $regexp\n"; return (0); } } ############### PROCEDURE PARSE IVY BUS PARAM sub _parseIvyBusParam ($) { my $ivyBus = shift; my ($ivyNetworks, $ivyPort) = $ivyBus =~ /^(.*):(.*)/; die ("Error in Ivy::_parseIvyBusParam, illegal bus address format: $ivyBus\n") unless $ivyPort =~ /^\d+$/; my @ivyAddrInet = (); $ivyNetworks =~ s/ //g; my @broadcastAddrs = split (',', $ivyNetworks); foreach my $netAddr (@broadcastAddrs) { $netAddr = BROADCAST_ADDRS if (($netAddr eq '') || ($netAddr =~ /^127/) || ($netAddr =~ /^loopback/)); # deux cas de figure : on a un nom de sous reseau, ou # une adresse ip de la forme \d+.\d+.... my $netAddrInet; if ($netAddr !~ /^(\d+\.)+\d+/) { # on a un nom de reseau, il faut trouver son adresse ip # on contourne un bug : Si les adresses sont incompletes # dans la map network : 143.196.53 au lieu de 143.196.53.255 # getbyname renvoie une adresse de type 0.143.196.53. # on doit donc faire un decalage des octets vers la gauche, # chaque 0 qui sort a gauche est remplace par un 255 a droite. my $networkAddr = getnetbyname ($netAddr); unless (defined $networkAddr) { warn ("Warning in Ivy::_parseIvyBusParam, network $netAddr is unknown\n"); next; } my @dummyNetAddr = unpack ("CCCC", pack ('N', $networkAddr)); 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; push (@dummyNetAddr, 255); } $netAddrInet = pack ("CCCC", @dummyNetAddr); } 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/; $netAddrInet = inet_aton ($netAddr); } push (@ivyAddrInet, pack_sockaddr_in ($ivyPort, $netAddrInet)); } unless (scalar @ivyAddrInet) { push (@ivyAddrInet, pack_sockaddr_in ($ivyPort, inet_aton(BROADCAST_ADDRS))); } foreach my $ivyAddr (@ivyAddrInet) { my ($port, $iaddr) = unpack_sockaddr_in($ivyAddr); my $iaddrH = unpack ("H8",$iaddr); my $iaddrInt = join (".", unpack ("C4", $iaddr)); print "Broadcasting on network $iaddrInt ($iaddrH) on port $ivyPort\n"; } return ($ivyPort, \@ivyAddrInet); } ############# Procedure _SUBSTITUTE ESCAPED CHAR sub _substituteEscapedChar ($$) { my ($scope, $reg) = @_; my %escapeRegexp = REG_PERLISSISME; # Si on fait la substitution dans une classe de caractere # on elimine les crochets. grep ($escapeRegexp{$_} =~ s/[\[\]]//g, keys %escapeRegexp) if ($scope eq 'inside') ; $reg =~ s/\\([wWsSdDne])/$escapeRegexp{$1}/ge; return $reg; } 1; __END__ =head1 NAME Ivy - Perl extension for implementing a software bus =head1 SYNOPSIS use Ivy; =head1 DESCRIPTION The Ivy perl module implements a software bus that provides easy communication between applications. Messages are broadcast as ASCII strings over a network defined by a list of domains and a port. Messages are received if they match a regular expressions and if your application is on the same network as remote ones. Before receive or send message you must call 'init', and 'new' class methods, followed by 'start' method. When you quit your application don't forget to call 'exit' class methods. =head1 CLASS METHODS =over 2 =item B Ivy->init(...); Ivy::init(...); Allows one to define global parameters which may be used as default ones at object creation time. Parameters are : =over 4 =item B<-loopMode =E 'TK'|'LOCAL'> Mode of events loop among TK or LOCAL. According to this mode, you must use Ivy->mainLoop or Tk::MainLoop(3) =item B<-appName =E 'your app ivy name'> Name of your application used to identify on ivy bus. =item B<-ivyBus =E 'domain 1,...,domain n:port number'> 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. =item B<-messWhenReady =E 'your message when ready'> Synchronisation message sent when application is ready to receive and send messages. =item B<-onDieFunc =E [\&yourdiefunc, @parameters]> =item B<-onDieFunc =E [$an_object, \&a_method, @parameters]> A callback or method to call when your application receive a suicide request. Do not call exit() in the callback, Ivy will do it for you. The prototype of your callback must be as follows: sub MyCallback { my @parameters = @_; ... } The prototype of your method must be as follows: sub MyMethod { my ($self, @parameters) = @_; ... } =item B<-pruneRegexp =E ['subject 1', ..., 'subject n']> Optimize communication using this option. Regexps which don't match these subjects are removed. Example : Ivy->init(-loopMode =E 'TK', -appName =E 'MyWonderfulApp', -onDieFunc =E [\&restorecontext]); =back =item B Ivy::new(...); Ivy->new(...); Check parameters, and create an Ivy bus object. You must call Ivy->init before creating a bus. Parameters are : =over 4 =item B<-appName =E 'your application name'> Name of your application used to identify it with other applications connected on the same bus. =item B<-ivyBus =E 'domain 1,...,domain n:port number'> A list of domains, followed by port number where to broadcast messages. Default is 127:2010 =item B<-messWhenReady =E 'your message when ready'> Synchronisation message sent when your application is ready to receive and send messages. =item B<-onDieFunc =E [\&yourdiefunc, @parameters]> =item B<-onDieFunc =E [$an_object, \&a_method, @parameters]> A callback or method called when your application receives a suicide request. Do not call exit() in the callback, Ivy will do it for you. The prototype of your callback must be as follows: sub MyCallback { my @parameters = @_; ... } The prototype of your method must be as follows: sub MyMethod { my ($self, @parameters) = @_; ... } =item B<-pruneRegexp =E ['subject 1', ..., 'subject n']> Optimize communication using this option. Regexps which don't match these subjects are removed. =item B<-neededApp =E ['app 1', ..., 'app n']> A list of applications that your application needs present on the bus before running. =item B<-statusFunc =E sub {}> A callback which will be called every time an appli is connected on the bus, deconnected from the bus or subscribes to a regexp. The first 3 parameters are a reference to an array of connected appli, a reference to an array of not connected appli (according to the "-neededApp" argument of the new method/function), a reference to a hash table of connected appli (giving the number of such appli). These 3 parameters are maintained for upwards compatibility but should no more be used, since the following three parameters are much easier to use: the name of an appearing/disapearing or subscribing/unsubscribing appli, its status either "new" or "died" or "subscribing" or "unsubscribing", and the hostname where this appli is running/dying OR the subscribed / unsubscribed regexp. Your callback could be: sub MyCallback { my ($ref_array_present, $ref_array_absent, $ref_hash_present, $appname, $status, $host_or_regexp) = @_; # $status is either new or died my %present=%$ref_hash_present; foreach my $remoteapp (keys %present) { if ($present{$remoteapp} > 1) { print "n apps $remoteapp are presents on bus\n"; } } if ($status eq "new") { print "$appname connected from $host_or_regexp\n"; } elsif ($status eq "died") { print "$appname disconnected from $host_or_regexp\n"; } elsif ($status eq "subscribing") { print "$appname subscribes to $host_or_regexp\n"; } elsif ($status eq "unsubscribing") { print "$appname unsubscribed to $host_or_regexp\n"; } } Example: Ivy->new(-ivyBus => '156,157:2204', -onDieFunc => [\&restorecontext], -neededApp => ["DataServer", "HMI"], -statusFunc => \&MyCallback); =back =item B Ivy->mainLoop; Ivy::mainLoop; Local main events loop. Use it if you don't use the Tk library. =item B $ivyobj->stop; Ivy::stop; To stop the Ivy main loop. =back =head1 OBJECT METHODS =over 2 =item B $ivyobj->start; Ivy::start; You must call this after you are ready to communicate through an Ivy bus and before you really communicate. The method returns the $ivyobj. =item B $ivyobj->sendMsgs(@messages); Ivy::sendMsgs(@messages); Send a list of messages Example : $ivyobj->sendMsgs("Hello", "Don't Bother", "Y2K is behind us"); =item B $ivyobj->sendAppNameMsgs(@messages); Ivy::sendAppNameMsgs(@messages); Send a list of messages preceded by your application's name. Example : $ivyobj->sendMsgs("Hello World"); # it will send "$appName Hello World" over the Ivy bus =item B $ivyobject->bindRegexp($regexp, [\&callback, @cb_parameters]); Ivy::bindRegexp($regexp, [\&callback, @cb_parameters]); $ivyobject->bindRegexp($regexp, [$an_obj, \&method, @cb_parameters]); Ivy::bindRegexp($regexp, [$an_obj, \&method, @cb_parameters]); 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 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. Example : $ivyobject->bindRegexp("\w+ (\d+)", [\&callback, @cb_parameters]); # Your callback will be called with one more parameter which will be # the name of appli who send the message # Your callback and method must be like: sub callback { my ($sendername, @cb_parameters, @matched_regexps_in_brackets) = @_; ... } sub method { my ($self, $sendername, @cb_parameters, @matched_regexps_in_brackets) = @_; ... } # to unbind: $ivyobject->bindRegexp("\w+ (\d+)"); =item B $ivyobj->sendDirectMsgs($to, $id, @msgs); Ivy::sendDirectMsgs($to, $id, @msgs); Send a message a message to appli $to. This appli must have done a bindDirect before to accept this message. regexp matching is not used with direct Messages =item B $ivyobj->bindDirect($regexp, $id, [\&callback, @cb_parameters]); Ivy::bindDirect($id, [\&callback, @cb_parameters]); The callback will be called with both the @msgs and the @cb_parameters. Example : $ivyobject->bindDirectMessage("id1", [\&callback, @cb_parameters]); # Your callback and method must be like: sub cb { my (@cb_parameters, @msgs) = @_; ... } sub method { my ($self, @cb_parameters, @msgs) = @_; ... } =item B $ivyobj->sendDieTo($to); Ivy::sendDieTo($to); Send a suicide to the application named $to. =item B $ivyobj->ping($to, $timeout); Ivy::ping($to, $timeout); Send a ping message and wait until timeout to receive a pong. =item B $after_id = $ivyobj->after($timeAfter, \@callbacks_list); $after_id = Ivy::after($timeAfter, \@callbacks_list); Call a list of callbacks after $timeAfter milliseconds. =item B $repeat_id = $ivyobj->repeat($timeAfter, \@callbacks_list); $repeat_id = Ivy:repeat($timeAfter, \@callbacks_list); Have a list of callbacks repeatedly called every $timeAfter milliseconds. =item B $ivyobj->afterCancel($after_or_repeat_id); Ivy::afterCancel($after_or_repeat_id); Cancel an after callback call. =item B $ivyobj->afterResetTimer($after_id); Ivy::afterResetTimer($after_id); Reset a timer if this timer has not yet been triggered. =item B $ivyobj->fileEvent($fd, $cb); Ivy::fileEvent($fd, $cb); Add a fileEvent handler (or remove any handler associated to $fd if $cb paramter is omitted). The callback $cb will get the filehandle $fd as parameter. =item B $ivyobj->DESTROY; Destroy the $ivyobj object. No other method should be applied to the reference of this deleted object. This method should not be used directly. =back =head1 BUGS The stop method does not work! In the statusFunc, an agent is identified by its name which is not garantted as unique No other known bugs at this time. If you find one, please report them to the authors. =head1 SEE ALSO perl(1), perlre(1), ivyprobe.pl(1) =head1 AUTHORS Alexandre Bustico , Herve Damiano , Stephane Chatty , Christophe Mertz =head1 COPYRIGHT CENA (C) 1997-2002 =head1 HISTORY =cut