diff options
Diffstat (limited to 'src/Ivy2.pm')
| -rw-r--r-- | src/Ivy2.pm | 1845 |
1 files changed, 0 insertions, 1845 deletions
diff --git a/src/Ivy2.pm b/src/Ivy2.pm deleted file mode 100644 index ebcb4ba..0000000 --- a/src/Ivy2.pm +++ /dev/null @@ -1,1845 +0,0 @@ -# -# Ivy, Perl interface -# -# Copyright 1997-2000 -# Centre d'Études de la Navigation Aérienne -# -# Authors: Alexandre Bustico <bustico@tls.cena.fr> -# Stéphane Chatty <chatty@tls.cena.fr> -# Hervé Damiano <damiano@tls.cena.fr> -# -# All functions -# -# $Id$ -# -# Please refer to the debian/copyright file for the -# copyright notice regarding this software -# - -package Ivy2 ; - -use Sys::Hostname; -use IO::Socket; -use strict ; -use Time::Gettimeofday ; - - -use vars qw($VERSION); -$VERSION = '4.3'; - -############################################################################# -#### 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 <<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 - # 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 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 transormer 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' => '[ ]', - 'S' => '[^ ]', - '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 ##### -############################################################################# - - -# 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 queueList => $constantIndexer++; -use constant threadList => $constantIndexer++; -use constant appliList => $constantIndexer++; -use constant sendRegList => $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, %options) = @_; - - # valeurs par defaut pour le parametre : variable d'environnement - # ou valeur cablee, a defaut - my $default_ivyBus = defined $ENV{"IVYBUS"} ? $ENV{"IVYBUS"} : ""; - - my %defaultOptions = ( #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. - ) ; - - - foreach my $opt (keys %defaultOptions) { - # si un parametre n'a pas ete defini - next if defined $options{$opt} ; - # est-il facultatif - if (defined $defaultOptions{$opt}) { - $options{$opt} = $defaultOptions{$opt} ; - } - else { - # parametre obligatoire - die "ERREUR Ivy::init vous devez specifier ". - "l'option $opt\n"; - } - } - - foreach my $opt (keys %options) { - die "ERREUR Ivy::init option $opt inconnue\n" unless - exists ($defaultOptions{$opt}); - } - - my $loopMode = $options{-loopMode}; - $ivyBus = $options{-ivyBus} ne "" ? $options{-ivyBus} : undef; - $appName = $options{-appName} ; - $messWhenReady = - $options{-messWhenReady} eq "_APP NAME READY" ? - "$appName READY" : $options{-messWhenReady}; - - $onDieFunc = $options{-onDieFunc} ; - @topicRegexps = @{$options{-pruneRegexp}}; - - 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 "l'argument \"mainloop mode\" doit etre TK ou 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 "ERREUR Ivy::new vous devez initialiser le module via Ivy->init ()"; - } - - # No de port tcp du serveur - $self->[servPort] = ''; - - # liste des applis necessaires a l'appli locale - $self->[neededApp] = []; - - # callback prenant en param 2 refs sur des listes : - # [applis presentes, appli absentes] - # cette fonction est appelee : - # - tout les pollingTime tant que toutes les applis - # ne sont pas presentes - # - des que toutes les applis sont presentes - # - 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] = {}; - - # 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 lacture ne se termine - # pas par \n, de maniere a resegmenter les messages - $self->[buffByConn] = {}; - - - my %defaultOptions = ( - -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. - ) ; - - - foreach my $opt (keys %defaultOptions) { - # si un parametre n'a pas ete defini - next if defined $options{$opt} ; - # est-il facultatif - if (defined $defaultOptions{$opt}) { - $options{$opt} = $defaultOptions{$opt} ; - } else { - # parametre obligatoire - die "ERREUR Ivy::new vous devez specifier ". - "l'option $opt\n"; - } - } - - foreach my $opt (keys %options) { - die "ERREUR Ivy::start option $opt inconnue\n" unless - exists ($defaultOptions{$opt}); - } - - - - $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]}) { - next unless exists ($self->[queueList]->{$fd}); - - foreach my $fd (values %{$self->[sockList]}) { - send ($fd, sprintf (MSG_FMT, BYE, 0, ""), 0) - or $self->_removeFileDescriptor ($fd); - } - } - - # on clos la socket de signalisation (UDP) - # print "DBG> fermeture de supSock\n"; - $self->[supSock]->close() if $self->[supSock]; - delete $allBuses{$self}; - - # on clos 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 = shift; - - # 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 "Ivy::start envoi du bonjour a echoue sur : $!\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]) ; -} - - -############### PROCEDURE BIND REGEXP -sub bindRegexp ($$$) { - my ($self, $regexp, $cb) = @_; - - # 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| - ( - (?<!\\) \[ # 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 \ - ) - | - _substituteEscapedChar ('inside', $1) - |xge; - - $regexp = _substituteEscapedChar ('outside', $regexp); - # print ("DBG regexp = $regexp\n"); - - 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]}; - } - $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, $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 ($@) -{ - use attrs qw(locked); - - my ($self, @msgs) = @_; - my $total = 0; - - # pour tous les messages - foreach my $msg (@msgs) { - 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 ($@) -{ - use attrs qw(locked); - - my ($self, @msgs) = @_; - my $total = 0; - - # pour tous les messages - foreach (@msgs) { - 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, $to, $id, @msgs) = @_; - - if (defined ($self->[appliList]{$to})) { - my @fds = @{$self->[appliList]{$to}}; - # pour tous les messages - foreach my $msg (@msgs) { - foreach my $fd (@fds) { - send ($fd, sprintf (MSG_FMT, DIRECT_MSG, $id, "$msg"), 0) - or $self->_removeFileDescriptor ($fd); - } - } - return 1; - } else { - warn "Ivy::sendDirectMsgs appli $to inconnue\n"; - return 0; - } -} - - -############### METHOD SEND DIE TO -sub sendDieTo ($$) -{ - use attrs qw(locked); - my ($self, $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 "Ivy::sendDieTo appli $to inconnue\n" if $^W; - return 0; - } -} - - -############### METHOD PING -sub ping ($$$) -{ - use attrs qw(locked); - - my ($self, $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 "Erreur Ivy->mainLoop, Ivy doit etre initialise en mode". - " loopMode local\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 ou la fonction soit - # appelee de maniere objet : premier argument = class ou une instance - # de classe - shift if ((ref ($_[0]) eq 'Ivy') || ($_[0] eq 'Ivy')) ; - - 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 ou la fonction soit - # appelee de maniere objet : premier argument = class ou une instance - # de classe - - shift if ((ref ($_[0]) eq 'Ivy') || ($_[0] eq 'Ivy')) ; - # 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 ou la fonction soit - # appelee de maniere objet : premier argument = class ou une instance - # de classe - shift if ((ref ($_[0]) eq 'Ivy') || ($_[0] eq 'Ivy')) ; - - 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 FILE EVENT -sub fileEvent ($$;$) -{ - # test du premier argument au cas ou la fonction soit - # appelee de maniere objet : premier argument = class ou une instance - # de classe - shift if ((ref ($_[0]) eq 'Ivy') || ($_[0] eq 'Ivy')) ; - - my ($fd, $cb) = @_; - - - unless (defined $localLoopSel) { - die ("Erreur Ivy::fileEvent : Ivy::fileEvent n'est utilisable qu'en ". - "mode mainLoop LOCALE\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 "Attention : Ivy::_getBonjour recv error, bonjour non traite\n"; - return; - } - - my $addr = (unpack_sockaddr_in ($inetAddr))[1]; - - my $peerName = gethostbyaddr ($addr, AF_INET); - print "peerName=$peerName\n"; - # on force $peerPort a etre vu comme une valeur numerique - my ($version, $peerPort) = $bonjourMsg =~ /^(\d+)\s+(\d+)/; - - unless (defined ($version) && defined ($peerPort)) { - warn "Attention : Ivy::_getBonjour format du message bonjour incorrect\n". - "message = $bonjourMsg\n" ; - return; - } - - if ($version != IVY_PROTOCOLE_VERSION) { - warn "Attention : Ivy::_getBonjour VERSION: demande de connexion de ". - "$peerName\n version courrante : " . IVY_PROTOCOLE_VERSION . ", recue : $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 "bonjour de $peerName ignore, ne fait pas partie des ivyBus\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->[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 "Attention Ivy::_getBonjour impossible de se connecter au serveur" . - "$peerName:$peerPort\n" ; - } -} - - -############### PROCEDURE GET CONNECTIONS -sub _getConnections ($) -{ - my $self = shift; - print "_getConnections\n"; - my $appSock = $self->[connSock]->accept(); - - unless (defined $appSock) { - warn "Attention 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->[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 "Attention Ivy::_getMessages malformated 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); - 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 ("Attention Ivy::_getMessages reception d'un message ". - "MSG : id $id inconnu de $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 - 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->[sendRegList]{$appSock}->[$id] = eval <<'_EOL_'; - sub { - use strict; - if (my @args = ${$_[0]} =~ /($valeurs)/o) { - 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 ("Attention Ivy::_getMessages ERREUR recue de ". - "$senderName : «$valeurs»\n"); - } - elsif ($type == DELREGEXP) { # D E L R E G E X P - # on vire la regexp des regexps vefifier - $self->[sendRegList]{$appSock}->[$id] = undef ; - } - 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; - } - - $self->_scanConnStatus (); - } - elsif ($type == APP_NAME) { - # etat Connecte - if (($self->[appName] eq $valeurs) && $^W) { - warn "\033[1mATTENTION : Ivy::_getMessages une instance de ". - "$self->[appName] existe deja\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 "Attention Ivy::_getMessages reception d'un message ". - "DIRECT d'id $id inconnue de $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 "Attention Ivy::_getMessages reception d'un ordre " . - "de suicide de $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 ("reception d'un message de type $type inconnu de " . - "$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 : deconnection de NONAME\n" if $^W; - return; - } - - my $addrInet = (grep ($self->[cnnxion]{$_} eq $diedAppName, - keys %{$self->[cnnxion]}))[0]; - - unless (defined $addrInet) { - die "ERREUR _removeFileDescriptor deconnection de $diedAppName ". - "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 - $self->_scanConnStatus () ; -} - - -############### 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 = shift; - - 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); -} - - -############### METHODE TO BE PRUNED -sub _toBePruned ($$$) -{ - my ($self, $from, $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 ("Erreur Ivy::_parseIvyBusParam format de l'adresse ou ". - "no de port incorrect : $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 ("Ivy::_parseIvyBusParam reseau inconnu : $netAddr\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 etes omis. - ($netAddr .= ".255.255.255") =~ s/^((\d+\.){3}\d+).*/$1/; - $netAddrInet = inet_aton ($netAddr); - } - - push (@ivyAddrInet, pack_sockaddr_in ($ivyPort, $netAddrInet)); - } - 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 to provide with an easy -communication between applications. Messages are broadcasted 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 - -=head2 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<gt> '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<gt> 'your app ivy name'> - -Name of your application used to identify on ivy bus. - -=item B<-ivyBus =E<gt> 'domain 1,...,domain n:port number'> - -A list of domains, followed by port number where to broadcast messages. -Default is 127.255.255.255:2010 - -=item B<-messWhenReady =E<gt> 'your message when ready'> - -Synchronisation message sent when application is ready to receive and send -messages. - -=item B<-onDieFunc =E<gt> [\&yourdiefunc, @parameters]> - -=item B<-onDieFunc =E<gt> [$an_object, \&a_method, @parameters]> - -A callback or method to call when application receive die message. -Don't make an exit in callback, ivy we'll do it for you. - -Prototype of your callback must be : - -sub MyCallback { - my @parameters = @_; - - ... -} - -Prototype of your method must be : - -sub MyMethod { - my ($self, @parameters) = @_; - - ... -} - -=item B<-pruneRegexp =E<gt> ['subject 1', ..., 'subject n']> - -Optimize communication using this option. Regexps which don't match these subjects are removed. - -Example : - - Ivy->init(-loopMode =E<gt> 'TK', - -appName =E<gt> 'MyWonderfulApp', - -onDieFunc =E<gt> [\&restorecontext]); - -=back - -=head2 Ivy->new(...); - -Check parameters, and create an ivy bus object. You must call Ivy->init before -this one. - -Parameters are : - -=over 4 - -=item B<-appName =E<gt> 'your app ivy name'> - -Name of your application used to identify on ivy bus. - -=item B<-ivyBus =E<gt> 'domain 1,...,domain n:port number'> - -A list of domains, followed by port number where to broadcast messages. -Default is 127.255.255.255:2010 - -=item B<-messWhenReady =E<gt> 'your message when ready'> - -Synchronisation message sent when application is ready to receive and send -messages. - -=item B<-onDieFunc =E<gt> [\&yourdiefunc, @parameters]> - -=item B<-onDieFunc =E<gt> [$an_object, \&a_method, @parameters]> - -A callback or method to call when application receive die message. -Don't make an exit in callback, ivy we'll do it for you. -Prototype of your callback must be : - - sub MyCallback { - my @parameters = @_; - ... - } - -Prototype of your method must be : - - sub MyMethod { - my ($self, @parameters) = @_; - ... - } - -=item B<-pruneRegexp =E<gt> ['subject 1', ..., 'subject n']> - -Optimize communication using this option. Regexps which don't match these subjects are removed. - -=item B<-neededApp =E<gt> ['app 1', ..., 'app n']> - -A list of application your own one needs to correctly run. - -=item B<-statusFunc =E<gt> sub {}> - -A callback which will be called until every needed app is present on bus. - -Your callback could be : - - sub MyCallback { - my ($present, $absent, %present) = @_; - - foreach my $remoteapp (keys %present) { - if ($present{$remoteapp} > 1) { - print "n apps $remoteapp are presents on bus\n"; - } - } - -Example : - - Ivy->new(-ivyBus => '156.255.255.255,157.255.255.255:2204', - -onDieFunc => [\&restorecontext], - -neededApp => ["DataServer", "HMI"], - -statusFunc => \&startwhenpresents); - -=back - -=head2 Ivy->mainLoop; - -Local main events loop. Use it if you don't use Tk library. - -=head2 $ivyobj->stop; - -=head1 OBJECT METHODS - -=head2 $ivyobj->start; - -You must call it after you are ready to communicate through ivy bus -and before you really communicate. - -=head2 $ivyobj->sendMsgs(@messages); - -Send a list of messages - -Example : - - $ivyobj->sendMsgs("Hello World", "Don't Bother", "Y2K is behind us"); - -=head2 $ivyobj->sendAppNameMsgs(@messages); - -Send a list of messages precedeed by ivy application name. - -Example : - - $ivyobj->sendMsgs("Hello World"); - # it will send "$appName Hello World" over ivy bus - -=head2 $ivyobject->bindRegexp($regexp, [\&callback, @cb_parameters]); - -=head2 $ivyobject->bindRegexp($regexp, [$an_obj, \&method, @cb_parameters]); - -Allow one to associate a message which matches a regular expression and a -callback or method. See perlre(1), to find how to write regexps. -Use the bracketing construct ( ... ), so that ivy perl will call -callback with matched patterns as parameters. - -Example : - - $ivyobject->bindRegexp("\w+ (\d+)", [\&callback, @cb_parameters]); - # You callback will be called with one more parameter which will be - # a number precedeed by a word, because of bracketed regexp. - -Your callback and method protos must be : - - sub cb { - my ($sendername, @cb_parameters, - @matched_regexps_in_brackets) = @_; - ... - } - - sub method { - my ($self, $sendername, @cb_parameters, - @matched_regexps_in_brackets) = @_; - ... - } - -=head2 $ivyobj->sendDirectMsgs($to, $id, @msgs); - -Send a message but Ask Alex to find what are $to and $id - -=head2 $ivyobj->bindDirect($regexp, $id, [\&callback, @cb_parameters]); - -=head2 $ivyobj->bindDirect($regexp, $id, [$an_obj, \&method, @cb_parameters]); - -Same as bindRegexp method but Ask Alex to find what is $id. - -=head2 $ivyobj->sendDieTo($to) - -send a die message to $to application name. - -=head2 $ivyobj->ping($to, $timeout); - -send a ping message and wait until timeout to receive a pong. - -=head2 $after_id = $ivyobj->after($timeAfter, \@callbacks_list); - -Call a list of callbacks after $timeAfter mseconds. - -=head2 $repeat_id = $ivyobj->repeat($timeAfter, \@callbacks_list); - -Repeat calls of a list of callbacks after $timeAfter mseconds. - -=head2 $ivyobj->afterCancel($after_or_repeat_id); - -Cancel an after callback call. - -=head2 $ivyobj->fileEvent($fd, $cb); - -Ask Alex - -=head2 $ivyobj->DESTROY; - -=head1 BUGS - -No know bugs at this time. Report them to author. - -=head1 SEE ALSO - -perl(1), perlre(1) - -=head1 AUTHORS - -Alexandre Bustico <bustico@tls.cena.fr>, Herve Damiano <damiano@tls.cena.fr> - -=head1 COPYRIGHT - -CENA (C) 1997-2000 - -=head1 HISTORY - -=cut |