path: root/Ivy.pm

#
# Ivy, Perl interface 
# 
# Copyright 1997-1999
# Centre d'Etudes de la Navigation Aerienne
#
# All functions
#
# $Id$
#

package Ivy ;

require 5.004 ;

use Sys::Hostname;
use IO::Socket;
use strict ;
use Time::Gettimeofday ;

#############################################################################
####                    PROTOTYPES                                      #####
#############################################################################
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 stop ();		# - 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 after ($$);		# temps en millisecondes, callback
sub repeat ($$);	# temps en millisecondes, callback
sub fileEvent ($$); # associe un fd a un callback pour la mainloop locale
sub pruneRegexp (@); # optimisation : si l'on connait les sujets des messages
		     # qu'on envoie, on appelle cette fonction avec une
		     # liste de sujets, et les regexps qui ne matchent pas
		     # ce sujet sont eliminees Cette fonction doit etre
		     # appelee avant le Ivy::start

################ 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 ($$);
#############################################################################
####                    CONSTANTES                                      #####
#############################################################################
use constant VERSION => 3;
use constant MSG_FMT => "%d %d\002%s\n";

# par defaut, on diffuse le bonjour en local
# (sauf pour l'instant, pour rester compatible)
#use constant BROADCAST_ADDRS => "127.255.255.255" ;
use constant BROADCAST_ADDRS => "143.196.1.255, 143.196.2.255, 143.196.53.255";

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 AFTER	=> 0;
use constant REPEAT	=> 1;
#############################################################################
####                    VARIABLES GLOBALES                              #####
#############################################################################
my $messWhenReady;	# message a envoyer a un canal lorsqu'on
			# a recu le message endregexp.

my $localAddr;		# adresse de la machine locale

my $servPort;		# No de port tcp du serveur

my $appName;		# Nom de l'appli locale

my @neededApp;		# liste des applis necessaires a l'appli locale

my $statusFunc;		# 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

my $onDieFunc;		# callback prenant en param 1 refs sur une liste :
			#  [ref sur fonction, parametres]

my $supSock ;		# socket de supervision en lecture/ecriture
my $connSock;		# socket de connexion tcp
		
my %sockList = ();	# tab ass : nom du fd => fd
my %appliList = ();     # tab ass : nom de l'appli => fd
	  
my %sendRegList = ();	# 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

my @topicRegexps = ();  # liste des topics qu'on envoie si on 
			# les regexps

my @recCbList = ();	# liste de ref sur des couples 
			# (regexp,callBack) les callbacks
			# sont appeles lors de
			# la reception de messages en fonction
			# du numero de regexp.

my @directCbList = ();  # liste de callBack pour les messages directs

my %cnnxion = ();	# 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

my %buffByConn = ();	# tableau associatif, clef => file desc,
			# valeur :buffer au cas ou la lacture ne se termine
			# pas par \n

my $fileEventFunc;      # pointeur sur la fonction permettant d'associer
			# des callbacks a un file desc, (ainsi que de
			# les enlever)


my $localLoopSel;       # dans le cas ou l'on soit dans une mainLoop
			# locale, cette var pointe une un objet
			# de type IO::Select;

my %localBindByHandle;  # table d'ass. handle -> callback
my %afterList=();       # tableau d'ass [AFTER ou REPEAT, 
			#   timeTotal, deadLine, [callback, arg, arg, ...]]

my $afterId = 0;	#

my $smallestTimout = 10000; # timeout le plus petit pour le select

my $maxInstanceOfApp ;  # nombre max d'instances de l'appli utilisant
			# le bus, si il y a deja $maxInstanceOfApp
			# instances on sort.

BEGIN {$SIG{'PIPE'} = sub {warn "broken pipe, ignoring ...\n";}}

#############################################################################
####                    PROCEDURES        PUBLIQUES                     #####
#############################################################################



############### PROCEDURE	BUS START
sub start (@) 
{
    my %options = @_;

    # valeurs par defaut pour le parametre : variable d'environnement
    # ou valeur cablee, a defaut
    my $default_domains = $ENV{"IVYDOMAINS"}; 
    $default_domains = BROADCAST_ADDRS unless defined ($default_domains);

    my %defaultOptions = ( #PARAMETRES OBLIGATOIRES
				-loopMode         => undef, 
			# TK ou LOCAL

		       		-appName	  => undef, 
			# nom de l'appli

			# PARAMETRES FACULTATIFS (avec valeurs par defaut)
		       		-broadcastPort    => $ENV{"BUS"}, 
			# No de port UDP Si non specifie la variable
		        # d'environnement BUS sera examinee

		       		-domains    => $default_domains,
			# Liste des domaines ou se fait le broadcast
		        # si non specifie, on utilise la variable
		        # d'environnement ou la valeur par defaut 
			
		       		-messWhenReady    => "_APP NAME READY",
			# message de synchro a envoyer quand pret

		       		-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 deux parametres passes sont :
		       # [liste des applis presentes], 
		       # [liste des applis absentes]

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


    foreach my $opt  (keys %defaultOptions) {
	# si un parametre n'a pas ete defini
	next if exists $options{$opt} ;
	# est-il facultatif
	if (defined $defaultOptions{$opt}) {
	    $options{$opt} = $defaultOptions{$opt} ;
	} else {
	    # parametre obligatoire
	    die "ERREUR Ivy::start vous devez specifier ".
		"l'option $opt\n";
	}
    }
    
    foreach my $opt  (keys %options) {
	die "ERREUR Ivy::start option $opt inconnue\n" unless
	    exists ($defaultOptions{$opt});
    }
    
    my $loopMode =	   $options{-loopMode};
    my $broadcastPort =    $options{-broadcastPort} ;
    my $broadcastAddrs =   $options{-domains} ;
    $appName =		   $options{-appName} ;
    $messWhenReady =       $options{-messWhenReady} eq "_APP NAME READY" ?
	"$appName READY" : $options{-messWhenReady};
    @neededApp =           @{$options{-neededApp}} ;
    $statusFunc =          $options{-statusFunc} ;
    $onDieFunc =	   $options{-onDieFunc} ;

    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 "le premier argument (mainloop mode) doit etre TK ou LOCAL\n";
    }

    # cree la socket de connexion, recupere le no de port
    $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] ;
    $cnnxion{"$hostAddr:". $connSock->sockport} = "\004";
    $cnnxion{"$localhostAddr:". $connSock->sockport} = "\004";
    
    # cree la socket de broadcast
    $supSock = IO::Socket::INET->new(LocalPort  => $broadcastPort,
                                     Proto      => 'udp',
                                     Type       => SOCK_DGRAM,
                                     Reuse      => 1);
    
    $supSock->sockopt (SO_BROADCAST, 1);

    
    # on determine la liste des adresses de broadcast
    $broadcastAddrs =~ s/ //g;
    my @broadcastAddrs = split (',', $broadcastAddrs);

    # et on envoie envoie le bonjour : "no de version no de port"
    my $bonjourMsg = sprintf ("%d %d\n", VERSION, $connSock->sockport());
    
    foreach my $netAddr (@broadcastAddrs) {
	# on complete la fin de l'adresse par des 255 si necessaire
	my @addrElems = split ('\.', $netAddr);
	$netAddr = '';
	my $i = 0;
	while ($i <4) {
		$netAddr .= (defined ($addrElems[$i]) ? $addrElems[$i] : '255');
		$netAddr .= '.' if ($i++ < 3);
	}
#	print "[$netAddr]\n";
	my $netAddrInet = inet_aton ($netAddr);
	my $netBroadcastAddr = pack_sockaddr_in ($broadcastPort, $netAddrInet);	
	send ($supSock, $bonjourMsg, 0, $netBroadcastAddr) or 
	    warn "Ivy::start envoi du bonjour a echoue sur $netAddr : $!\n";
    }    
    # callback pour traiter la reception des bonjours
    &$fileEventFunc ($supSock, \&_getBonjour) ;
    
    # callback pour traiter les demandes de cxion
    &$fileEventFunc ($connSock, \&_getConnections) ;
}

	   
############### PROCEDURE	BIND REGEXP	   
sub bindRegexp ($$)	   
{
    my ($regexp, $cb) = @_;
    
    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 <= ($#recCbList+1); $id++)  {
	    last unless  (defined $recCbList[$id]) && @{$recCbList[$id]->[1]};
	}
	$recCbList[$id] =  [$regexp, $cb];

	# on envoie les messages regexps aux processus deja connectes
	_sendLastRegexpToAllreadyConnected ($id) ;
    } else {
	# on vire le callback, et on se desabonne de cette regexp
	for (my $id=0; $id <= $#recCbList; $id++)  {
	    next unless (defined $recCbList[$id]) && @{$recCbList[$id]->[1]};
	    if ($recCbList[$id]->[0] eq $regexp) {
		$recCbList[$id]->[1] = [];
		# on envoie le mesage delregexp
		foreach my $fd (values %sockList) {
		    send ($fd, sprintf (MSG_FMT, DELREGEXP, $id), 0)
			or _removeFileDescriptor ($fd); 
	       }
	    }
	}
    }
}

############### PROCEDURE	BIND REGEXP	   
sub bindDirect ($$)	   
{
    my ($id, $cb) = @_;
    
    if ($cb) {
	# on rajoute la $cb dans la liste des messages
	# qu'on prend
	$directCbList[$id] =  $cb;
    } else {
	# on vire le callback
	undef $directCbList[$id];
    }
}


	   
############### PROCEDURE	SEND MSGS	    
sub sendMsgs (@)
{
    my @msgs = @_;
    my $total = 0;
    # pour tous les messages
    foreach my $msg (@msgs) {
	study ($msg);

	# pour routes les connections
	foreach my $fd (keys %sockList) {

	    # pour toutes les fonctions de filtrage de regexp
	    foreach my $regexpFunc (@{$sendRegList{$fd}}) {
		$total += &{$regexpFunc} (\$msg) if defined $regexpFunc;
	}
    }
  }
#    print "DBG> sended $total times\n";
    return $total;
}

############### PROCEDURE	SEND MSGS	    
sub sendAppNameMsgs (@)
{
    my @msgs = @_;
    my $total = 0;
    # pour tous les messages
    foreach (@msgs) {
	my $msg = "$appName $_";
	study ($msg);

	# pour routes les connections
	foreach my $fd (keys %sockList) {

	    # pour toutes les fonctions de filtrage de regexp
	    foreach my $regexpFunc (@{$sendRegList{$fd}}) {
		$total += &{$regexpFunc} (\$msg) if defined $regexpFunc;
	    }
	}
    }
#    print "DBG> sended $total times\n";
    return $total;
}



############### PROCEDURE	SEND DIRECT MSGS	    
sub sendDirectMsgs ($$@)
{
    my ($to, $id, @msgs) = @_;
    
    if (defined ($appliList{$to})) {
	my @fds = @{$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 _removeFileDescriptor ($fd); 
	    }
	}
	return 1;
    } else {
	warn "Ivy::sendDirectMsgs appli $to inconnue\n";
	return 0;
    }
}


############### PROCEDURE	SEND DIE TO	    
sub sendDieTo ($)
{
  my $to = shift;
    
  if (defined ($appliList{$to})) {
    my @fds = @{$appliList{$to}};
    # pour tous les messages
    foreach my $fd (@fds) {
      _sendDieTo ($fd);
    }
    return 1;
  } else {
    warn "Ivy::sendDieTo appli $to inconnue\n";
    return 0;
  }
}


############### PROCEDURE	PING    
sub ping ($$)
{
    my ($to, $timeout) = @_;
    
    if (defined ($appliList{$to})) {
	my @fds = @{$appliList{$to}};
	# pour tous les messages
	foreach my $fd (@fds) {
	    send ($fd, sprintf (MSG_FMT, PING, 0, " "), 0)
		or _removeFileDescriptor ($fd); 
	}
    }
}


############### PROCEDURE	IVY STOP
sub stop ()
{
    # pour toutes les connections
    foreach my $fd (values %sockList) {
	send ($fd, sprintf (MSG_FMT, BYE, 0, ""), 0) 
	    or _removeFileDescriptor ($fd);
    }
}


############### PROCEDURE       MAINLOOP
sub mainLoop ()
{
    for (;;) {
	my @ready = $localLoopSel->can_read ($smallestTimout) ;
	_scanAfter () ;
        foreach my $fd (@ready) {
            if (ref $localBindByHandle{$fd} eq 'CODE') {
                &{$localBindByHandle{$fd}} ;
            } else {
                my ($cb, @arg) = @{$localBindByHandle{$fd}} ;
                &$cb (@arg)
            }
        }
    }
}
 

############### PROCEDURE	AFTER	
sub after ($$)
{
   my ($timeAfter,  $cbListRef) = @_;   
   $timeAfter /= 1000;
   $smallestTimout = $timeAfter if $timeAfter < $smallestTimout;

   # 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);
}

############### PROCEDURE	AFTER	
sub repeat ($$)
{
    # on passe le temps en secondes pour le select
    my ($timeAfter,  $cbListRef) = @_;
    $timeAfter /= 1000;
    $smallestTimout = $timeAfter if $timeAfter < $smallestTimout;

    $afterList{++$afterId}= [REPEAT, $timeAfter, timeofday()+$timeAfter, 
			      $cbListRef];
    return ($afterId);
}

############### PROCEDURE	AFTER CANCEL	
sub afterCancel ($)
{
    my $id = shift;
    
    if (defined ($id) && defined $afterList{$id}) {
	if ($afterList{$id}->[1] <= $smallestTimout) {
	    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;
	    $smallestTimout = 10000;
	    foreach my $af (values %afterList) {
		$smallestTimout = $af->[1] if $af->[1] < $smallestTimout ;
	    }
	} else {
	    delete $afterList{$id} ;
	}
    }
}

sub pruneRegexp (@)
{
    @topicRegexps = @_;
}

#############################################################################
####                    PROCEDURES        PRIVEE                        #####
#############################################################################


############### PROCEDURE	GET BONJOUR 	
sub _getBonjour ()
{
    my $bonjourMsg = '';

    # l'hote distant
    my $inetAddr = $supSock->recv ($bonjourMsg, 1024, 0);
    unless (length $inetAddr) {
	warn "recv error, bonjour non traite\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 "ERREUR format du message bonjour incorrect\n".
	    "message = $bonjourMsg\n" ;
	return;
    }
    if ($version != VERSION) {
	warn "ERREUR VERSION: demande de connexion de $peerName\n".
	    "version courrante : " . 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 ($cnnxion{"$addr:$peerPort"})) {
#	print "DBG> : bonjour de $peerName:$peerPort : DEJA CONNECTE\n" ;
	return ;
    } else {
#	print "DBG> : reception de $peerName : bonjour $peerPort\n" ;
    }
    $cnnxion{"$addr:$peerPort"} = 1;
    
    # 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
	$sendRegList{$appSock} = [];
	$buffByConn{$appSock} = '';
	$sockList{$appSock} = $appSock;
	&$fileEventFunc ($appSock, [\&_getMessages, $appSock]) ;

	# on balance les regexps qui nous interessent a l'appli distante
	_sendWantedRegexp ($appSock);
    } else {
 	warn "Ivy::_getBonjour ERROR cannot connect to server " .
	    "$peerName:$peerPort\n" ;
    }
}


############### PROCEDURE	GET CONNECTIONS
sub _getConnections ()
{
    my $appSock = $connSock->accept();

    unless (defined $appSock) {
	warn "ERROR _getConnections, \$appSock not defined\n";
	return;
    } else {
	#print sprintf ("accepting connection from %s:%d\n", 
	#	       (gethostbyaddr ($appSock->peeraddr(),AF_INET))[0],
	#	       $appSock->peerport());
    }
	
    # callback pour traiter la reception des messages
    &$fileEventFunc ($appSock, [\&_getMessages,  $appSock]) ;

    # on cree une entree pour $appSock dans la liste des regexp
    $sendRegList{$appSock} = [];
    $buffByConn{$appSock} = '';
    $sockList{$appSock} = $appSock;
    # on balance les regexps qui nous interessent a l'appli distante
    _sendWantedRegexp ($appSock);
}


############### PROCEDURE	GET MESSAGES
sub _getMessages ($)
{
    my $appSock = shift;
    my $mess;
    my $buffer = '';
    my ($addr, $peerPort, $senderName);

    # on recupere le message
    recv ($appSock, $buffer, 2048, 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
	_removeFileDescriptor ($appSock);
	return;
    }
    
    if (length ($buffByConn{$appSock})) {
	$buffer = $buffByConn{$appSock} . $buffer ;
	$buffByConn{$appSock} = '';
    }
    my @messages = split ('\n', $buffer) ;
    $buffByConn{$appSock} = pop (@messages) unless ($buffer =~ /\n$/) ;

#     if (defined $appSock->peername) {
    $addr = $appSock->peeraddr(); 
    $peerPort = $appSock->peerport() ;
    $senderName = $cnnxion{"$addr:$peerPort"} ;
    $senderName = "NONAME" unless $senderName;

#    } else {
#	warn "\n\nBIG PB : appSock->peername undefined \n\n";
#    }

    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 "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 = @{$recCbList[$id]->[1]}) {
		my $cb = shift @cb;
		# on split sur ETX
		&$cb ($senderName, @cb, split ("\003", $valeurs)) ;
	    } else {
		#_sendErrorTo ($appSock, "REEGXP ID $id inconnue");
		warn ("reception d'un message MSG : id $id inconnu de " .
		      "$senderName :\n«$mess»");
	    }
	} elsif ($type == BYE) {
	    #print "reception d'un bye\n";
	    _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 _toBePruned ($senderName, $valeurs);
	    unless (defined $sendRegList{$appSock}->[$id]) {
		# si l'id de regexp n'etait pas utilisee c'est tout bon
		# on affecte la nouvelle regexp a un id
		$sendRegList{$appSock}->[$id] = sub {
		    if (my @args = ${$_[0]} =~ /($valeurs)/) {
		    shift @args;
		    $args[$#args] .= "\003" if @args;
		    send ($appSock, sprintf (MSG_FMT,
					     MSG, $id, join ("\003",@args)), 0)
			or _removeFileDescriptor ($appSock) ;
		    return 1;
#		    print join (' ', "DBG > J'envoie MSG", $id, @args, "\n");
		} 
	    };
	}  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
	    _sendErrorTo ($appSock, "ID $id deja utilisee");
	}
    } elsif ($type == ERROR) {				# E R R O R
	warn ("ERREUR de $senderName : «$valeurs»\n")
	} elsif ($type == DELREGEXP) {			# D E L   R E G E X P
	    # on vire la regexp des regexps vefifier
	    $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
	    _sendMsgTo ($appSock, $messWhenReady);
	    # on passe de l'etat Connecte a l'etat Ready
	    $cnnxion{"$addr:$peerPort"} =~ s/^\004//;
	    my $apName = $cnnxion{"$addr:$peerPort"};
	    unless (exists $appliList{$apName}) {
		$appliList{$apName} = [$appSock];
	    } else {
		push @{$appliList{$apName}},  $appSock;
	    }
	    _scanConnStatus ();
	} elsif ($type == APP_NAME) {	
	    # etat Connecte
	    if ($appName eq $valeurs){
		warn "\033[1mATTENTION : une instance de $appName ".
		    "existe deja\033[m\n" ;
	    }
	    $senderName = $cnnxion{"$addr:$peerPort"} = "\004$valeurs";
	} elsif ($type == DIRECT_MSG) {	
	    if (defined $directCbList[$id]) {
		my @cb = @{$directCbList[$id]};
		my $cb = shift @cb;
		&$cb (@cb, $valeurs);
  	    } else {
		_sendErrorTo ($appSock, "DIRECT ID $id inconnue");
		warn "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;
	    &$cb (@cb);
	    # on avertit les autres qu'on se barre
	    my $adr = _inetAdrByName ($senderName) ;
	    warn "reception d'un ordre de suicide de $senderName ($adr)".
		"... exiting\n";
	    stop ();
	    # adios
	    exit ();
	} elsif ($type == PING) {
	    # si on recois un ping, on envoie un pong
	    _pong ($appSock);
	} elsif ($type == PONG) {
	    return PONG;
	} else  {
	    _sendErrorTo ($appSock, "TYPE DE MESS $type inconnu");
	    warn ("reception d'un message de type $type inconnu de " . 
		  "$senderName :\n«$mess»");
	}
     } 
return 0;
}

############### PROCEDURE	SEND WANTED REGEXP	
sub _sendWantedRegexp ($)
{
    my $appSock = shift;

    # on envoie le message "Nom appli"
    send ($appSock, sprintf (MSG_FMT, APP_NAME, 0, $appName), 0)
	or _removeFileDescriptor ($appSock) ;

    # on envoie les regexps
    for (my $id = 0; $id <= $#recCbList; $id++) {
	next unless defined $recCbList[$id] ;
	send ($appSock , 
	      sprintf (MSG_FMT, REGEXP, $id, $recCbList[$id]->[0]),
	      0) or _removeFileDescriptor ($appSock) ;
#	print sprintf ("DBG > %s %d %s\n", 
#			 'REGEXP', $id, $recCbList[$id]->[0]);
    }
    # on envoie le message de fin d'envoi de regexps
    send ($appSock, sprintf (MSG_FMT, ENDREGEXP, 0, ""), 0)  
	or _removeFileDescriptor ($appSock) ;
}

############### PROCEDURE	SEND LAST REGEXP TO ALLREADY CONNECTED
sub _sendLastRegexpToAllreadyConnected ($)
{
    my $id = shift;
    foreach my $fd (values %sockList) {
	send ($fd, sprintf (MSG_FMT, REGEXP, $id, $recCbList[$id]->[0]), 
	      0) or _removeFileDescriptor ($fd) ;
    }
}

############### PROCEDURE	INET ADR BY NAME
sub _inetAdrByName ($) {
    my $appName = shift;

    my $addrInet = (grep ($cnnxion{$_} eq $appName, keys %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 $fd = shift;
    my $diedAppName;
    # on vire ce fd des fd a scruter dans la bcle d'evenements
    &$fileEventFunc ($fd, '') ;
    # on clos la connection
    delete $sendRegList{$fd};
    delete $sockList{$fd};
    close ($fd);

  EXT_LOOP:
    foreach my $name (keys %appliList) {
	foreach my $fdp (@{$appliList{$name}}) {
	    if ($fd eq $fdp) {
		$diedAppName = $name;
		@{$appliList{$name}} = grep ($_ ne $fdp, @{$appliList{$name}});
		last EXT_LOOP;
	    }
	}
    }
    
    unless (defined $diedAppName) {
	print "_removeFileDescriptor : deconnection de NONAME\n" ;
	return;
    }

    my $addrInet = (grep ($cnnxion{$_} eq $diedAppName, keys %cnnxion))[0];
    unless (defined $addrInet) {
	die "ERREUR _removeFileDescriptor deconnection de $diedAppName ".
	    "addrInet not defined\n";
	return;
    }
    #printf "deconnection de %s ($diedAppName)\n", _inetAdrByName ($diedAppName);
    delete $cnnxion{$addrInet};
    
    # on vire l'entree correspondant a ce canal dans la liste des
    # regexps par canal
    _scanConnStatus () ;
}


############### PROCEDURE	SEND ERROR TO
sub _sendErrorTo ($$)
{
    my ($fd, $error) = @_;

    send ($fd, join (' ', ERROR, "0\002$error\n"), 0) 
	or _removeFileDescriptor ($fd);
}


############### PROCEDURE	PONG
sub _pong ($)
{
    my $fd = shift;

    send ($fd, join (' ', PONG, "0\002 \n"), 0) 
	or _removeFileDescriptor ($fd);
}


############### PROCEDURE	SEND ERROR TO
sub _sendDieTo ($)
{
    my $fd = shift;

    send ($fd, join (' ', DIE, "0\002\n"), 0) 
	or _removeFileDescriptor ($fd);
}


############### PROCEDURE	SEND MSG TO
sub _sendMsgTo ($$)
{
    my ($fd, $msg) = @_;

    # pour toutes les fonctions de filtrage de regexp
    foreach my $regexpFunc (@{$sendRegList{$fd}}) {
	&{$regexpFunc} (\$msg) if defined $regexpFunc;
    }
}


############### PROCEDURE	TK FILE EVENT	
sub _tkFileEvent ($$)
{
  my ($fd, $cb) = @_;
    
  Tk::fileevent ('', $fd, 'readable', $cb) ;
}


############### PROCEDURE	BUS FILE EVENT 	
sub fileEvent ($$)
{
    my ($fd, $cb) = @_;

    if ($cb) {
	# adding the handler
	$localBindByHandle{$fd} = $cb;
	$localLoopSel->add ($fd);
    } else  {
	# deleting the handler
	delete $localBindByHandle{$fd};
	$localLoopSel->remove ($fd);
    }
}



############### PROCEDURE	SCAN AFTER
sub _scanAfter ()
{
    my $stamp = timeofday ();
    foreach my $afk (keys %afterList) {
	my $af = $afterList{$afk};
	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] ;
	    } else {
		# si c'est un after on le vire
		afterCancel ($afk);
	    }
	}
    }
}


############### PROCEDURE	SCAN CONN STATUS	
sub _scanConnStatus ()
{
    my (%readyApp, @nonReadyApp);

    foreach (values %cnnxion) {
	$readyApp{$_} = 1 unless /^\004/; # connecte mais pas ready

    }
	
    foreach (@neededApp) {
	push (@nonReadyApp, $_) unless exists $readyApp{$_};
    }

    &$statusFunc ([keys %readyApp], \@nonReadyApp);
}


############### PROCEDURE	TO BE PRUNED
sub _toBePruned ($$)
{
    my ($from, $regexp) = @_;


    # si il n'y a pas de liste de sujets, on ne
    # filtre pas
    return 0 unless @topicRegexps;

    unless ($regexp =~ /^\^/) {
	#print "DBG> regexp non ANCREE de $from : $regexp\n";
	return (0);
    }
    
    if ($regexp =~ /^\^(\w+)/) {
	my $topic = $1;
	if (grep (/$topic/, @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);
    }
}


1;