sympa.pl

#! --PERL--
# sympa.pl - This script is the main one ; it runs as a daemon and does
# the messages/commands processing
# RCS Identication ; $Revision$ ; $Date$ 
#
# Sympa - SYsteme de Multi-Postage Automatique
# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU 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 General Public License for more details.
#
# You should have received a copy of the GNU 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.

use strict;

use lib '--LIBDIR--';
#use Getopt::Std;
use Getopt::Long;

use Mail::Address;
use File::Path;

use Commands;
use Conf;
use Auth;
use SympaSession;
use Language;
use Log;
use Version;
use mail;
use MIME::QuotedPrint;
use List;
use Message;
use admin;
use Config_XML;
use Family;
use report;
use File::Copy;

require 'tools.pl';
require 'tt2.pl';
require 'parser.pl';

# durty global variables
my $is_signed = {}; 
my $is_crypted ;


## Internal tuning
# delay between each read of the digestqueue
my $digestsleep = 5; 

## Init random engine
srand (time());

my $version_string = "Sympa version is $Version\n";

my $daemon_name = &Log::set_daemon($0);
my $ip;
$ip = $ENV{'REMOTE_HOST'};
$ip = $ENV{'REMOTE_ADDR'} unless ($ip);

my $usage_string = "Usage:
   $0 [OPTIONS]

Options:
   -d, --debug                           : sets Sympa in debug mode 
   -f, --config=FILE                     : uses an alternative configuration file
   --import=list\@dom                    : import subscribers (read from STDIN)
   -k, --keepcopy=dir                    : keep a copy of incoming message
   -l, --lang=LANG                       : use a language catalog for Sympa
   -m, --mail                            : log calls to sendmail
   --service=process_command|process_message|process_creation  : process dedicated to messages distribution, commands or to automatic lists creation (default three of them)
   --dump=list\@dom|ALL                  : dumps subscribers 
   --make_alias_file                     : create file in /tmp with all aliases (usefull when aliases.tpl is changed)
   --lowercase                           : lowercase email addresses in database
   --md5_encode_password                 : rewrite password in database using md5 fingerprint. YOU CAN'T UNDO unless you save this table first
   --create_list --robot=robot_name --input_file=/path/to/file.xml 
                                         : create a list with the xml file under robot_name
   --instantiate_family=family_name  --robot=robot_name --input_file=/path/to/file.xml [--close_unknown] [--quiet]
                                         : instantiate family_name lists described in the file.xml under robot_name,
                                           the family directory must exist ;
                                           automatically close undefined lists in a new instantation if --close_unknown specified,
                                           do not print report if --quiet specified.
  --add_list=family_name --robot=robot_name --input_file=/path/to/file.xml
                                         : add the list described by the file.xml under robot_name, to the family
                                           family_name.
   --modify_list=family_name --robot=robot_name --input_file=/path/to/file.xml
                                         : modify the existing list installed under the robot_name robot and that 
                                           belongs to family_name family. The new description is in the file.xml
   --close_family=family_name --robot=robot_name 
                                         : close lists of family_name family under robot_name.      

   --close_list=listname\@robot          : close a list
   --purge_list=listname\@robot          : remove a list no backup is possible
   --sync_include=listname\@robot        : trigger the list members update
   --reload_list_config --list=mylist\@mydom  : recreates all config.bin files. You should run this command if you edit 
                                                authorization scenarios. The list parameter is optional.
   --upgrade [--from=X] [--to=Y]             : runs Sympa maintenance script to upgrade from version X to version Y
   --log_level=LEVEL                     : sets Sympa log level
   --md5_digest=password                 : output a MD5 digest of a password (usefull for SOAP client trusted application)
   -h, --help                            : print this help
   -v, --version                         : print version number

Sympa is a mailinglists manager and comes with a complete (user and admin)
web interface. Sympa  can be linked to an LDAP directory or an RDBMS to 
create dynamic mailing lists. Sympa provides S/MIME and HTTPS based authentication and
encryption.
";

## Check --dump option
my %options;
unless (&GetOptions(\%main::options, 'dump=s', 'debug|d', ,'log_level=s','foreground', 'service=s','config|f=s', 
		    'lang|l=s', 'mail|m', 'keepcopy|k=s', 'help', 'version', 'import=s','make_alias_file','lowercase','md5_encode_password',
		    'close_list=s','purge_list=s','create_list','instantiate_family=s','robot=s','add_list=s','modify_list=s','close_family=s','md5_digest=s',
		    'input_file=s','sync_include=s','upgrade','from=s','to=s','reload_list_config','list=s','quiet','close_unknown')) {
    &fatal_err("Unknown options.");
}

if ($main::options{'debug'}) {
    $main::options{'log_level'} = 2 unless ($main::options{'log_level'});
}
## Batch mode, ie NOT daemon
$main::options{'batch'} = 1 if ($main::options{'dump'} || 
				$main::options{'help'} ||
				$main::options{'version'} || 
				$main::options{'import'} || 
				$main::options{'make_alias_file'} ||
				$main::options{'lowercase'} ||
				$main::options{'md5_encode_password'} ||
				$main::options{'close_list'} ||
				$main::options{'purge_list'} ||
				$main::options{'create_list'} ||
				$main::options{'instantiate_family'} ||
				$main::options{'add_list'} ||
				$main::options{'modify_list'} ||
				$main::options{'close_family'} ||
				$main::options{'md5_digest'} || 
				$main::options{'sync_include'} ||
				$main::options{'upgrade'} ||
				$main::options{'reload_list_config'}
				 );

# Some option force foreground mode
$main::options{'foreground'} = 1 if ($main::options{'debug'} || $main::options{'batch'});

$main::options{'log_to_stderr'} = 1 unless ($main::options{'batch'});
$main::options{'log_to_stderr'} = 1 if ($main::options{'upgrade'} || $main::options{'reload_list_config'});

my @parser_param = ($*, $/);
my %loop_info;
my %msgid_table;

# this loop is run foreach HUP signal received
my $signal = 0;

local $main::daemon_usage; 

while ($signal ne 'term') { #as long as a SIGTERM is not received }

my $config_file = $main::options{'config'} || '--CONFIG--';
## Load configuration file
unless (Conf::load($config_file)) {
   &fatal_err("Configuration file $config_file has errors.");
   
}

## Open the syslog and say we're read out stuff.
do_openlog($Conf{'syslog'}, $Conf{'log_socket_type'}, 'sympa');

# setting log_level using conf unless it is set by calling option
if ($main::options{'log_level'}) {
    &Log::set_log_level($main::options{'log_level'});
    do_log('info', "Configuration file read, log level set using options : $main::options{'log_level'}"); 
}else{
    &Log::set_log_level($Conf{'log_level'});
    do_log('info', "Configuration file read, default log level $Conf{'log_level'}"); 
}

## Probe Db if defined
if ($Conf{'db_name'} and $Conf{'db_type'}) {
    unless (&Upgrade::probe_db()) {
	&fatal_err('Database %s defined in sympa.conf has not the right structure or is unreachable. If you don\'t use any database, comment db_xxx parameters in sympa.conf', $Conf{'db_name'});
    }
}

## Apply defaults to %List::pinfo
&List::_apply_defaults();

&tools::ciphersaber_installed();

if (&tools::cookie_changed($Conf{'cookie'})) {
     &fatal_err("sympa.conf/cookie parameter has changed. You may have severe inconsitencies into password storage. Restore previous cookie or write some tool to re-encrypt password in database and check spools contents (look at $Conf{'etc'}/cookies.history file)");
}

## Set locale configuration
$main::options{'lang'} =~ s/\.cat$//; ## Compatibility with version < 2.3.3
$Language::default_lang = $main::options{'lang'} || $Conf{'lang'};

## Main program
if (!chdir($Conf{'home'})) {
   fatal_err("Can't chdir to %s: %m", $Conf{'home'});
   ## Function never returns.
}

if ($main::options{'service'} eq 'process_message') {
    $main::daemon_usage = DAEMON_MESSAGE;
}elsif ($main::options{'service'} eq 'process_command') {
    $main::daemon_usage = DAEMON_COMMAND;
}elsif ($main::options{'service'} eq 'process_creation') {
    $main::daemon_usage = DAEMON_CREATION;
}else{
    $main::daemon_usage = DAEMON_ALL; # default is to run one sympa.pl server for commands, messages and automatic lists creation. 
}

## Check for several files.
unless (&Conf::checkfiles_as_root()) {
   fatal_err("output checkfiles_as_root : Missing files. Aborting.");
   ## No return.
}

## Check that the data structure is uptodate
unless ($main::options{'upgrade'} || $main::options{'help'}) {
    unless (&Upgrade::data_structure_uptodate()) {
	&fatal_err("error : data structure was not updated ; you should run sympa.pl --upgrade to run the upgrade process.");
    }
}

if ($signal ne 'hup') {
    ## Put ourselves in background if we're not in debug mode. That method
    ## works on many systems, although, it seems that Unix conceptors have
    ## decided that there won't be a single and easy way to detach a process
    ## from its controlling tty.
    unless ($main::options{'foreground'}) {
	if (open(TTY, "/dev/tty")) {
	    ioctl(TTY, 0x20007471, 0);         # XXX s/b &TIOCNOTTY
	    #       ioctl(TTY, &TIOCNOTTY, 0);
	    close(TTY);
	}
	open(STDIN, ">> /dev/null");
	open(STDOUT, ">> /dev/null");
	open(STDERR, ">> /dev/null");

	setpgrp(0, 0);
	# start the main sympa.pl daemon

	## Fork a new process dedicated to automatic list creation, if required
	if (($Conf{'automatic_list_feature'} eq 'on') || $main::daemon_usage == DAEMON_CREATION) {
	    do_log('debug', "Starting server for automatic lists creation");
	    if ((my $child_pid = fork) != 0) {
		do_log('notice', "Server for automatic lists creation started, pid $child_pid");
		do_log('debug', "Server for automatic lists creation started, pid $child_pid, exiting from initial process");
	    }else {
		## We're in the specialized child process
		$main::daemon_usage = DAEMON_CREATION; # automatic lists creation	    
	    }
	}

	unless ($main::daemon_usage == DAEMON_CREATION) {

	    ## A single process that handles both messages and commands
	    ## The distribute/ spool is not used
	    if ($Conf{'distribution_mode'} eq 'single' && 
		
		$main::daemon_usage == DAEMON_ALL ) {
		my $purpose = 'all';
		&do_log('debug', "Starting server for $purpose purpose");
		if ((my $child_pid = fork) != 0) {
		    do_log('info', "Server started for $purpose, pid $child_pid");
		    do_log('debug', "$purpose server started, pid $child_pid, exiting from initial process");
		    exit(0);
		}
		
		## Starting a dedicated process if sympa.pl is started with a --service argument
	    }elsif ($main::daemon_usage == DAEMON_COMMAND ||
		    $main::daemon_usage == DAEMON_COMMAND){
		
		my $purpose;
		if ($main::daemon_usage == DAEMON_COMMAND) {$purpose = 'command';}
		elsif ($main::daemon_usage == DAEMON_MESSAGE) {$purpose = 'message';}
		do_log('debug', "Starting server for $purpose purpose");
		if ((my $child_pid = fork) != 0) {
		    do_log('info', "Server started for $purpose, pid $child_pid");
		    do_log('debug', "$purpose server started, pid $child_pid, exiting from initial process");
		    exit(0);
		}
		
		## Sympa forks to have 2 dedicated processes for processing commands and messages
	    }else{
		$main::daemon_usage = DAEMON_COMMAND; # fork sympa.pl dedicated to commands
		do_log('debug', "Starting server for commands");
		if ((my $child_pid = fork) != 0) {
		    do_log('info', "Server for commands started, pid $child_pid");
		    $main::daemon_usage = DAEMON_MESSAGE; # main process continue in order to fork
		    do_log('debug', "Starting server for messages");	    
		    if ((my $child_pid = fork) != 0) {
			do_log('notice', "Server for messages started, pid $child_pid");
			do_log('debug', "Server for messages started, pid $child_pid, exiting from initial process");
			exit(0);  # exit from main process
		    }
		}
	    }
	}
    }

    my $service = 'sympa';
    $service .= '(distribute)' if ($main::daemon_usage == DAEMON_MESSAGE);
    $service .= '(command)' if ($main::daemon_usage == DAEMON_COMMAND);
    $service .= '(creation)' if ($main::daemon_usage == DAEMON_CREATION);
    do_openlog($Conf{'syslog'}, $Conf{'log_socket_type'}, $service);

    do_log('debug', "Running server $$ for $service purpose ");
    unless ($main::options{'batch'} ) {

	## Create and write the pidfile
	my $file = $Conf{'pidfile'};
	$file = $Conf{'pidfile_distribute'} if ($main::daemon_usage == DAEMON_MESSAGE) ;
	$file = $Conf{'pidfile_creation'} if ($main::daemon_usage == DAEMON_CREATION) ;
	&tools::write_pid($file, $$);
    }	


    # Set the UserID & GroupID for the process
    $( = $) = (getgrnam('--GROUP--'))[2];
    $< = $> = (getpwnam('--USER--'))[2];

    ## Required on FreeBSD to change ALL IDs(effective UID + real UID + saved UID)
    &POSIX::setuid((getpwnam('--USER--'))[2]);
    &POSIX::setgid((getgrnam('--GROUP--'))[2]);

    ## Check if the UID has correctly been set (usefull on OS X)
    unless (($( == (getgrnam('--GROUP--'))[2]) && ($< == (getpwnam('--USER--'))[2])) {
	&fatal_err("Failed to change process userID and groupID. Note that on some OS Perl scripts can't change their real UID. In such circumstances Sympa should be run via SUDO.");
    }

    # Sets the UMASK
    umask(oct($Conf{'umask'}));

 ## Most initializations have now been done.
    do_log('notice', "Sympa $Version started");
}else{
    do_log('notice', "Sympa $Version reload config");
    $signal = '0';
}

## Check for several files.
## Prevent that 2 processes perform checks at the same time...
if ($main::daemon_usage == DAEMON_COMMAND ||
    $main::daemon_usage == DAEMON_ALL) {
    unless (&Conf::checkfiles()) {
	fatal_err("Missing files. Aborting.");
	## No return.
    }
}else {
    sleep 1; ## wait until main process has created required directories
}

## Daemon called for dumping subscribers list
if ($main::options{'dump'}) {
    
    my ($all_lists, $list);
    if ($main::options{'dump'} eq 'ALL') {
	$all_lists = &List::get_lists('*');
    }else {	
	
	## The parameter can be a list address
	unless ($main::options{'dump'} =~ /\@/) {
	    &do_log('err','Incorrect list address %s', $main::options{'dump'});
	    
	    exit;
	} 

	my $list = new List ($main::options{'dump'});
	unless (defined $list) {
	    &do_log('err','Unknown list %s', $main::options{'dump'});
	    
	    exit;
	}
	push @$all_lists, $list;
    }

    foreach my $list (@$all_lists) {
	unless ($list->dump()) {
	    printf STDERR "Could not dump list(s)\n";
	}
    }

    exit 0;
}elsif ($main::options{'help'}) {
    print $usage_string;
    exit 0;
}elsif ($main::options{'make_alias_file'}) {
    my $all_lists = &List::get_lists('*');
    unless (open TMP, ">/tmp/sympa_aliases.$$") {
	printf STDERR "Unable to create tmp/sympa_aliases.$$, exiting\n";
	exit;
    }
    printf TMP "#\n#\tAliases for all Sympa lists open (but not for robots)\n#\n";
    close TMP;
    foreach my $list (@$all_lists) {
	system ("$Conf{'alias_manager'} add $list->{'name'} $list->{'domain'} /tmp/sympa_aliases.$$") if ($list->{'admin'}{'status'} eq 'open');
    }
    printf ("Sympa aliases file is /tmp/sympa_aliases.$$ file made, you probably need to installed it in your SMTP engine\n");
    
    exit 0;
}elsif ($main::options{'version'}) {
    print $version_string;
    
    exit 0;
}elsif ($main::options{'md5_digest'}) {
    my $md5 = &tools::md5_fingerprint($main::options{'md5_digest'});
    printf "md5 digest : $md5 \n";
    
    exit 0;
}elsif ($main::options{'import'}) {
    my ($list, $total);

    ## The parameter should be a list address
    unless ($main::options{'import'} =~ /\@/) {
	&do_log('err','Incorrect list address %s', $main::options{'import'});
	exit;
    } 


    unless ($list = new List ($main::options{'import'})) {
	fatal_err('Unknown list name %s', $main::options{'import'});
    }

    ## Read imported data from STDIN
    while (<STDIN>) {
	next if /^\s*$/;
	next if /^\s*\#/;

	unless (/^\s*((\S+|\".*\")@\S+)(\s*(\S.*))?\s*$/) {
	    printf STDERR "Not an email address: %s\n", $_;
	}

	my $email = lc($1);
	my $gecos = $4;
	my $u;
	my $defaults = $list->get_default_user_options();
	%{$u} = %{$defaults};
	$u->{'email'} = $email;
	$u->{'gecos'} = $gecos;

	unless ($list->add_user($u)) {
	    printf STDERR "\nCould not add %s\n", $email;
	    next;
	}
	print STDERR '+';
	
	$total++;	
    }
    
    printf STDERR "Total imported subscribers: %d\n", $total;

    exit 0;
}elsif ($main::options{'md5_encode_password'}) {

    unless ($List::use_db) {
	&fatal_err("You don't have a database setup, can't lowercase email addresses");
    }
    
    my $total=&Upgrade::md5_encode_password();
    printf STDERR "Total password re-encoded using md5: %d\n", $total;
    
    exit 0;
    
}elsif ($main::options{'lowercase'}) {
    
    unless ($List::use_db) {
	&fatal_err("You don't have a database setup, can't lowercase email addresses");
    }

    print STDERR "Working on user_table...\n";
    my $total = &List::lowercase_field('user_table', 'email_user');

    print STDERR "Working on subscriber_table...\n";
    $total += &List::lowercase_field('subscriber_table', 'user_subscriber');

    unless (defined $total) {
	&fatal_err("Could not work on dabatase");
    }

    printf STDERR "Total lowercased rows: %d\n", $total;

    exit 0;
}elsif ($main::options{'close_list'}) {

    my ($listname, $robotname) = split /\@/, $main::options{'close_list'};
    my $list = new List ($listname, $robotname);

    unless (defined $list) {
	print STDERR "Incorrect list name $main::options{'close_list'}\n";
	exit 1;
    }

    if ($list->{'admin'}{'family_name'}) {
 	unless($list->set_status_family_closed('close_list',$list->{'name'})) {
 	    print STDERR "Could not close list $main::options{'close_list'}\n";
 	    exit 1;	
 	}
    } else {
	unless ($list->close()) {
	    print STDERR "Could not close list $main::options{'close_list'}\n";
	    exit 1;	
	}
    }

    printf STDOUT "List %s has been closed, aliases have been removed\n", $list->{'name'};
    
    exit 0;
}elsif ($main::options{'purge_list'}) {

    my ($listname, $robotname) = split /\@/, $main::options{'purge_list'};
    my $list = new List ($listname, $robotname);

    unless (defined $list) {
	print STDERR "Incorrect list name $main::options{'purge_list'}\n";
	exit 1;
    }

    if ($list->{'admin'}{'family_name'}) {
 	unless($list->set_status_family_closed('purge_list',$list->{'name'})) {
 	    print STDERR "Could not purge list $main::options{'purge_list'}\n";
 	    exit 1;	
 	}
    } else {
	unless ($list->purge()) {
	    print STDERR "Could not purge list $main::options{'close_list'}\n";
	    exit 1;	
	}
    }

    printf STDOUT "List %s has been closed, aliases have been removed\n", $list->{'name'};
    
    exit 0;
}elsif ($main::options{'create_list'}) {
    
    my $robot = $main::options{'robot'} || $Conf{'host'};
    
    unless ($main::options{'input_file'}) {
 	print STDERR "Error : missing 'input_file' parameter\n";
 	exit 1;
    }

    unless (open INFILE, $main::options{'input_file'}) {
	print STDERR "Unable to open $main::options{'input_file'}) file";
 	exit 1;	
    }
    
    my $config = new Config_XML(\*INFILE);
    unless (defined $config->createHash()) {
 	print STDERR "Error in representation data with these xml data\n";
 	exit 1;
    } 
    
    my $hash = $config->getHash();
    
    close INFILE;

    my $resul = &admin::create_list_old($hash->{'config'},$hash->{'type'},$robot,"command_line");
    unless (defined $resul) {
 	print STDERR "Could not create list with these xml data\n";
 	exit 1;
    }
    
    if (! defined($resul->{'aliases'}) || $resul->{'aliases'} == 1) {
 	printf STDOUT "List has been created \n";
 	exit 0;
    }else {
 	printf STDOUT "List has been created, required aliases :\n $resul->{'aliases'} \n";
 	exit 0;
    }
}elsif ($main::options{'instantiate_family'}) {
    
    my $robot = $main::options{'robot'} || $Conf{'host'};

    my $family_name;
    unless ($family_name = $main::options{'instantiate_family'}) {
 	print STDERR "Error : missing family parameter\n";
 	exit 1;
    }
    my $family;
    unless ($family = new Family($family_name,$robot)) {
 	print STDERR "The family $family_name does not exist, impossible instantiation\n";
 	exit 1;
    }

    unless ($main::options{'input_file'}) {
 	print STDERR "Error : missing input_file parameter\n";
 	exit 1;
    }

    unless (-r $main::options{'input_file'}) {
	print STDERR "Unable to read $main::options{'input_file'} file";
 	exit 1;	
    }

    unless ($family->instantiate($main::options{'input_file'}, $main::options{'close_unknown'})) {
 	print STDERR "\nImpossible family instantiation : action stopped \n";
 	exit 1;
    } 
        
    my %result;
    my $err = $family->get_instantiation_results(\%result);
    close INFILE;

    unless ($main::options{'quiet'}) {
        print STDOUT "@{$result{'info'}}";
        print STDOUT "@{$result{'warn'}}";
    }
    if ($err) {
        print STDERR "@{$result{'errors'}}";
    }
    
    exit 0;
}elsif ($main::options{'add_list'}) {
     
    my $robot = $main::options{'robot'} || $Conf{'host'};

    my $family_name;
    unless ($family_name = $main::options{'add_list'}) {
	print STDERR "Error : missing family parameter\n";
 	exit 1;
    }
    
    print STDOUT "\n************************************************************\n";
    
    my $family;
    unless ($family = new Family($family_name,$robot)) {
 	print STDERR "The family $family_name does not exist, impossible to add a list\n";
 	exit 1;
    }
    
    unless ($main::options{'input_file'}) {
 	print STDERR "Error : missing 'input_file' parameter\n";
 	exit 1;
    }

    unless (open INFILE, $main::options{'input_file'}) {
	print STDERR "\n Impossible to open input file  : $! \n";
 	exit 1;	
    }

    my $result;
    unless ($result = $family->add_list(\*INFILE)) {
 	print STDERR "\nImpossible to add a list to the family : action stopped \n";
 	exit 1;
    } 
    
    print STDOUT "\n************************************************************\n";
    
    unless (defined $result->{'ok'}) {
 	printf STDERR "\n%s\n", join ("\n", @{$result->{'string_info'}});
 	print STDERR "\n The action has been stopped because of error :\n";
 	printf STDERR "\n%s\n", join ("\n", @{$result->{'string_error'}});
 	exit 1;
    }
    
    close INFILE;

    print STDOUT "\n%s\n", join ("\n", @{$result->{'string_info'}});
    exit 0;
}elsif ($main::options{'sync_include'}) {

    my $list = new List ($main::options{'sync_include'});

    unless (defined $list) {
	print STDERR "Incorrect list name $main::options{'sync_include'}\n";
	exit 1;
    }

    unless (defined $list->sync_include()) {
	print STDERR "Failed to synchronize list members\n";
	exit 1;
    }

    printf "Members of list %s have been successfully update.\n", $list->get_list_address();
    exit 0;
## Migration from one version to another
}elsif ($main::options{'upgrade'}) {
    
    &do_log('notice', "Upgrade process...");

    $main::options{'from'} ||= &Upgrade::get_previous_version();
    $main::options{'to'} ||= $Version::Version;

    if ($main::options{'from'} eq $main::options{'to'}) {
	&do_log('err', "Current version : %s ; no upgrade is required.", $main::options{'to'});
	exit 0;
    }else {
	&do_log('notice', "Upgrading from %s to %s...", $main::options{'from'}, $main::options{'to'});
    }

    unless (&Upgrade::upgrade($main::options{'from'}, $main::options{'to'})) {
	&do_log('err',  "Migration from %s to %s failed", $main::options{'from'}, $main::options{'to'});
 	exit 1;
    }

    &do_log('notice', "Upgrade process finished.");    
    &Upgrade::update_version();

    exit 0;

## Reload binary list config files
}elsif ($main::options{'reload_list_config'}) {

    if ($main::options{'list'}) {

	&do_log('notice', "Loading list $main::options{'list'}...");
	my $list = new List ($main::options{'list'}, '', {'reload_config' => 1});
	unless (defined $list) {
	    print STDERR "Error : incorrect list name '$main::options{'list'}'\n";
	    exit 1;
	}
    }else {
	&do_log('notice', "Loading ALL lists...");
	my $all_lists = &List::get_lists('*',{'reload_config' => 1});
    }

    exit 0;
}

##########################################
elsif ($main::options{'modify_list'}) {
    
    my $robot = $main::options{'robot'} || $Conf{'host'};

    my $family_name;
    unless ($family_name = $main::options{'modify_list'}) {
 	print STDERR "Error : missing family parameter\n";
 	exit 1;
    }
    
    print STDOUT "\n************************************************************\n";
    
    my $family;
    unless ($family = new Family($family_name,$robot)) {
 	print STDERR "The family $family_name does not exist, impossible to modify the list.\n";
 	exit 1;
    }
    
    unless ($main::options{'input_file'}) {
 	print STDERR "Error : missing input_file parameter\n";
 	exit 1;
    }

    unless (open INFILE, $main::options{'input_file'}) {
	print STDERR "Unable to open $main::options{'input_file'}) file";
 	exit 1;	
    }

    my $result;
    unless ($result = $family->modify_list(\*INFILE)) {
 	print STDERR "\nImpossible to modify the family list : action stopped. \n";
 	exit 1;
    } 
    
    print STDOUT "\n************************************************************\n";
    
    unless (defined $result->{'ok'}) {
 	printf STDERR "\n%s\n", join ("\n", @{$result->{'string_info'}});
 	print STDERR "\nThe action has been stopped because of error :\n";
 	printf STDERR "\n%s\n", join ("\n", @{$result->{'string_error'}});
 	exit 1;
    }

    close INFILE;
    
    printf STDOUT "\n%s\n", join ("\n", @{$result->{'string_info'}});
    exit 0;
}

##########################################
elsif ($main::options{'close_family'}) {
    
    my $robot = $main::options{'robot'} || $Conf{'host'};

    my $family_name;
    unless ($family_name = $main::options{'close_family'}) {
 	print STDERR $usage_string;
 	exit 1;
    }
    my $family;
    unless ($family = new Family($family_name,$robot)) {
 	print STDERR "The family $family_name does not exist, impossible family closure\n";
 	exit 1;
    }
    
    my $string;
    unless ($string = $family->close()) {
 	print STDERR "\nImpossible family closure : action stopped \n";
 	exit 1;
    } 
    
    print STDOUT $string;
    exit 0;
}
 

## Do we have right access in the directory
if ($main::options{'keepcopy'}) {
    if (! -d $main::options{'keepcopy'}) {
	&do_log('notice', 'Cannot keep a copy of incoming messages : %s is not a directory', $main::options{'keepcopy'});
	delete $main::options{'keepcopy'};
    }elsif (! -w $main::options{'keepcopy'}) {
	&do_log('notice','Cannot keep a copy of incoming messages : no write access to %s', $main::options{'keepcopy'});
	delete $main::options{'keepcopy'};
    }
}

## Catch SIGTERM, in order to exit cleanly, whenever possible.
$SIG{'TERM'} = 'sigterm';
$SIG{'HUP'} = 'sighup';
$SIG{'PIPE'} = 'IGNORE'; ## Ignore SIGPIPE ; prevents sympa.pl from dying

my $index_queuedigest = 0; # verify the digest queue
my $index_cleanqueue = 0; 
my @qfile;

my $spool = $Conf{'queue'};
# if daemon is dedicated to message or automatic lists creation, change the current spool
if ($main::daemon_usage == DAEMON_MESSAGE) {
    $spool = $Conf{'queuedistribute'};
}elsif ($main::daemon_usage == DAEMON_CREATION) {
    $spool = $Conf{'queueautomatic'};
}

## This is the main loop : look for files in the directory, handles
## them, sleeps a while and continues the good job.
while (!$signal) {

    &Language::SetLang($Language::default_lang);

    &List::init_list_cache();

    if (!opendir(DIR, $spool)) {
	fatal_err("Can't open dir %s: %m", $spool); ## No return.
    }
    @qfile = sort tools::by_date grep (!/^\./,readdir(DIR));
    closedir(DIR);

    unless ($main::daemon_usage == DAEMON_COMMAND)  { # process digest only in distribution mode
	## Scan queuedigest
	if ($index_queuedigest++ >=$digestsleep){
	    $index_queuedigest=0;
	    &SendDigest();
	}
    }
    unless ($main::daemon_usage == DAEMON_MESSAGE) { # process expire and bads only in command mode 
    
	## Clean queue (bad)
	if ($index_cleanqueue++ >= 100){
	    $index_cleanqueue=0;
	    if (-e "$spool/bad") {
		&tools::CleanSpool("$spool/bad", $Conf{'clean_delay_queue'});
	    }
	    &tools::CleanSpool($Conf{'queuemod'}, $Conf{'clean_delay_queuemod'});
	    if (-e $Conf{'queueoutgoing'}.'/bad') {
		&tools::CleanSpool($Conf{'queueoutgoing'}.'/bad', $Conf{'clean_delay_queueoutgoing'});
	    }
	    if (-e $Conf{'queuebounce'}.'/bad') {
		&tools::CleanSpool($Conf{'queuebounce'}.'/bad', $Conf{'clean_delay_queuebounce'});
	    }
	    &tools::CleanSpool($Conf{'queueauth'}, $Conf{'clean_delay_queueauth'});
	    &tools::CleanSpool($Conf{'queuetopic'}, $Conf{'clean_delay_queuetopic'});
	    &tools::CleanSpool($Conf{'tmpdir'}, $Conf{'clean_delay_tmpdir'});
	    &tools::CleanSpool($Conf{'queuesubscribe'}, $Conf{'clean_delay_queuesubscribe'});
	    &tools::CleanSpool($Conf{'queueautomatic'}, $Conf{'clean_delay_queueautomatic'});
	}
    }
    my $filename;
    my $listname;
    my $robot;

    my $highest_priority = 'z'; ## lowest priority
    my $t_spool = $spool; ## in single mode we may have to supervise automatic spool
    
    ## Scans files in queue
    ## Search file with highest priority
    foreach my $t_filename (sort @qfile) {
	my $priority;
	my $type;
	my $list;
	my ($t_listname, $t_robot);
	
	# trying to fix a bug (perl bug ??) of solaris version
	($*, $/) = @parser_param;

	## test ever if it is an old bad file
	if ($t_filename =~ /^BAD\-/i){
 	    if ((stat "$t_spool/$t_filename")[9] < (time - &Conf::get_robot_conf($robot, 'clean_delay_queue')*86400) ){
 		unlink ("$t_spool/$t_filename") ;
		&do_log('notice',"Deleting bad message %s because too old", $t_filename);
	    };
	    next;
	}

	## z and Z are a null priority, so file stay in queue and are processed
	## only if renamed by administrator
	next unless ($t_filename =~ /^(\S+)\.\d+\.\w+$/);

	## Don't process temporary files created by queue (T.xxx)
	next if ($t_filename =~ /^T\./);

	($t_listname, $t_robot) = split(/\@/,$1);
	
	$t_listname = lc($t_listname);
	if ($t_robot) {
	    $t_robot=lc($t_robot);
	}else{
	    $t_robot = lc(&Conf::get_robot_conf($robot, 'host'));
	}

	my $list_check_regexp = &Conf::get_robot_conf($robot,'list_check_regexp');

	if ($t_listname =~ /^(\S+)-($list_check_regexp)$/) {
	    ($t_listname, $type) = ($1, $2);
	}

	# (sa) le terme "(\@$Conf{'host'})?" est inutile
	#unless ($t_listname =~ /^(sympa|$Conf{'listmaster_email'}|$Conf{'email'})(\@$Conf{'host'})?$/i) {
	#    $list = new List ($t_listname);
	#}

	my $email = &Conf::get_robot_conf($robot, 'email');	

	if ($t_listname eq $Conf{'listmaster_email'}) {
	    ## highest priority
	    $priority = 0;
	}elsif ($type eq 'request') {
	    $priority = &Conf::get_robot_conf($robot, 'request_priority');
	}elsif ($type eq 'owner') {
	    $priority = &Conf::get_robot_conf($robot, 'owner_priority');
	}elsif ($t_listname =~ /^(sympa|$email)(\@$Conf{'host'})?$/i) {	
	    $priority = &Conf::get_robot_conf($robot,'sympa_priority');
	}else {
	    my $list =  new List ($t_listname, $t_robot, {'just_try' => 1});
	    if ($list) {
		$priority = $list->{'admin'}{'priority'};
	    }else {
		$priority = &Conf::get_robot_conf($robot, 'default_list_priority');
	    }
	}
	
	if (ord($priority) < ord($highest_priority)) {
	    $highest_priority = $priority;
	    $filename = $t_filename;
	}
    } ## END of spool lookup

    &mail::reaper;

    unless ($filename) {
	sleep(&Conf::get_robot_conf($robot, 'sleep'));
	next;
    }

    &do_log('debug', "Processing %s/%s with priority %s", $t_spool,$filename, $highest_priority) ;
    
    if ($main::options{'mail'} != 1) {
	$main::options{'mail'} = $robot if (&Conf::get_robot_conf($robot, 'log_smtp'));
    }

    ## Set NLS default lang for current message
    $Language::default_lang = $main::options{'lang'} || &Conf::get_robot_conf($robot, 'lang');

    my $status = &DoFile("$t_spool/$filename");
    
    if (defined($status)) {
	&do_log('debug', "Finished %s", "$t_spool/$filename") ;

	if ($main::options{'keepcopy'}) {
	    unless (&File::Copy::copy($t_spool.'/'.$filename, $main::options{'keepcopy'}.'/'.$filename) ) {
 		&do_log('notice', 'Could not rename %s to %s: %s', "$t_spool/$filename", $main::options{'keepcopy'}."/$filename", $!);
	    }
	}
	unlink("$t_spool/$filename");
    }else {
	my $bad_dir = "$t_spool/bad";
	
	if (-d $bad_dir) {
	    unless (rename("$t_spool/$filename", "$bad_dir/$filename")){
		&fatal_err("Exiting, unable to rename bad file $filename to $bad_dir/$filename (check directory permission)");
	    }
	    do_log('notice', "Moving bad file %s to bad/", $filename);
	}else{
	    do_log('notice', "Missing directory '%s'", $bad_dir);
	    unless (rename("$t_spool/$filename", "$t_spool/BAD-$filename")) {
		&fatal_err("Exiting, unable to rename bad file $filename to BAD-$filename");
	    }
	    do_log('notice', "Renaming bad file %s to BAD-%s", $filename, $filename);
	}	
    }

} ## END of infinite loop

## Dump of User files in DB