#! /usr/bin/perl
# -*- indent-tabs-mode: nil; -*-
# vim:ft=perl:et:sw=4
# $Id: task_manager.pl.in 12680 2016-02-13 06:24:50Z sikeda $

# Sympa - SYsteme de Multi-Postage Automatique
#
# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites
# Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016 GIP RENATER
#
# 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, see <http://www.gnu.org/licenses/>.

use lib split(/:/, $ENV{SYMPALIB} || ''), '/usr/local/libdata/perl5/site_perl';
use strict;
use warnings;
use English qw(-no_match_vars);
use Getopt::Long;
use Pod::Usage;
use POSIX qw();
use Template;

use Sympa;
use Sympa::Alarm;
use Conf;
use Sympa::Constants;
use Sympa::Crash;    # Show traceback.
use Sympa::DatabaseManager;
use Sympa::List;
use Sympa::Log;
use Sympa::Process;
use Sympa::Scenario;
use Sympa::Session;
use Sympa::Spool;
use Sympa::Task;
use Sympa::Ticket;
use Sympa::Tools::File;
use Sympa::Tools::Time;
use Sympa::Tools::Text;
use Sympa::Tracking;
use Sympa::User;

my $process = Sympa::Process->instance;
$process->init(pidname => 'task_manager');

my %options;
unless (
    GetOptions(
        \%main::options, 'config|f=s',  'debug|d', 'help|h',
        'version|v',     'log_level=s', 'foreground|F'
    )
    ) {
    pod2usage(-exitval => 1, -output => \*STDERR);
}
if ($main::options{'help'}) {
    pod2usage(0);
} elsif ($main::options{'version'}) {
    printf "Sympa %s\n", Sympa::Constants::VERSION;
    exit 0;
}
$Conf::sympa_config = $main::options{config};

if ($main::options{'debug'}) {
    $main::options{'log_level'} = 2 unless $main::options{'log_level'};
    $main::options{'foreground'} = 1;
}

my $log = Sympa::Log->instance;
$log->{log_to_stderr} = 'all' if $main::options{'foreground'};

my $adrlist = {};

# Load sympa.conf
unless (Conf::load()) {
    die sprintf
        "Unable to load Sympa configuration, file %s or one of the virtual host robot.conf files contain errors. Exiting.\n",
        Conf::get_sympa_conf();
}

$log->openlog($Conf::Conf{'log_facility'}, $Conf::Conf{'log_socket_type'});

# setting log_level using conf unless it is set by calling option
if ($main::options{'log_level'}) {
    $log->{level} = $main::options{'log_level'};
    $log->syslog(
        'info',
        'Configuration file read, log level set using options: %s',
        $main::options{'log_level'}
    );
} else {
    $log->{level} = $Conf::Conf{'log_level'};
    $log->syslog(
        'info',
        'Configuration file read, default log level %s',
        $Conf::Conf{'log_level'}
    );
}

# Put ourselves in background if not in debug mode.
unless ($main::options{'foreground'}) {
    $process->daemonize;
}

# Create and write the PID file.
$process->write_pid(initial => 1);
# If process is running in foreground, don't write STDERR to a dedicated file.
unless ($main::options{foreground}) {
    $process->direct_stderr_to_file;
}

## Set the UserID & GroupID for the process
$GID = $EGID = (getgrnam(Sympa::Constants::GROUP))[2];
$UID = $EUID = (getpwnam(Sympa::Constants::USER))[2];

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

# Check if the UID has correctly been set (useful on OS X)
unless (($GID == (getgrnam(Sympa::Constants::GROUP))[2])
    && ($UID == (getpwnam(Sympa::Constants::USER))[2])) {
    die
        "Failed to change process user ID and group ID. Note that on some OS Perl scripts can't change their real UID. In such circumstances Sympa should be run via sudo.\n";
}

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

## Change to list root
unless (chdir($Conf::Conf{'home'})) {
    die sprintf 'Unable to change to directory %s', $Conf::Conf{'home'};
}

## Catch signals, in order to exit cleanly, whenever possible.
$SIG{'TERM'} = \&sigterm;
$SIG{'INT'}  = \&sigterm;
my $end = 0;

# Most initializations have now been done.
$log->syslog('notice', 'Task_Manager %s Started',
    Sympa::Constants::VERSION());

###### VARIABLES DECLARATION ######

my $spool_task = $Conf::Conf{'queuetask'};
my @tasks;    # list of tasks in the spool

# won't execute send_msg and delete_subs commands if true, only log
undef my $log_only;
#$log_only = 1;

## list of list task models
#my @list_models = ('expire', 'remind', 'sync_include');
my @list_models = ('sync_include', 'remind');

## hash of the global task models
my %global_models = (
    'expire_bounce_task'               => 'expire_bounce',
    'purge_user_table_task'            => 'purge_user_table',
    'purge_logs_table_task'            => 'purge_logs_table',
    'purge_session_table_task'         => 'purge_session_table',
    'purge_spools_task'                => 'purge_spools',
    'purge_tables_task'                => 'purge_tables',
    'purge_one_time_ticket_table_task' => 'purge_one_time_ticket_table',
    'purge_orphan_bounces_task'        => 'purge_orphan_bounces',
    'eval_bouncers_task'               => 'eval_bouncers',
    'process_bouncers_task'            => 'process_bouncers',
);

## month hash used by epoch conversion routines
my %months = (
    'Jan', 0, 'Feb', 1, 'Mar', 2, 'Apr', 3, 'May', 4,  'Jun', 5,
    'Jul', 6, 'Aug', 7, 'Sep', 8, 'Oct', 9, 'Nov', 10, 'Dec', 11
);

###### DEFINITION OF AVAILABLE COMMANDS FOR TASKS ######

my $date_arg_regexp1 = '\d+|execution_date';
my $date_arg_regexp2 = '(\d\d\d\dy)(\d+m)?(\d+d)?(\d+h)?(\d+min)?(\d+sec)?';
my $date_arg_regexp3 =
    '(\d+|execution_date)(\+|\-)(\d+y)?(\d+m)?(\d+w)?(\d+d)?(\d+h)?(\d+min)?(\d+sec)?';
my $delay_regexp = '(\d+y)?(\d+m)?(\d+w)?(\d+d)?(\d+h)?(\d+min)?(\d+sec)?';
my $var_regexp   = '@\w+';
my $subarg_regexp =
    '(\w+)(|\((.*)\))';    # for argument with sub argument (ie arg(sub_arg))

# regular commands
my %commands = (
    'next' => ['date', '\w*'],
    # date   label
    'stop'   => [],
    'create' => ['subarg', '\w+', '\w+'],
    #object    model  model choice
    'exec' => ['.+'],
    #file    #delay
    'expire_bounce' => ['\d+'],
    #template  date
    'sync_include'                => [],
    'purge_user_table'            => [],
    'purge_logs_table'            => [],
    'purge_session_table'         => [],
    'purge_spools'                => [],
    'purge_tables'                => [],
    'purge_one_time_ticket_table' => [],
    'purge_orphan_bounces'        => [],
    'eval_bouncers'               => [],
    'process_bouncers'            => []
);

# commands which use a variable. If you add such a command, the first
# parameter must be the variable
my %var_commands = (
    'delete_subs' => ['var'],
    # variable
    'send_msg' => ['var', '\w+'],
    #variable template
    'rm_file' => ['var'],
    # variable
);

foreach (keys %var_commands) {
    $commands{$_} = $var_commands{$_};
}

# commands which are used for assignments
my %asgn_commands = (
    'select_subs' => ['subarg'],
    # condition
    'delete_subs' => ['var'],
    # variable
);

foreach (keys %asgn_commands) {
    $commands{$_} = $asgn_commands{$_};
}

###### INFINITE LOOP SCANING THE QUEUE (unless a sig TERM is received) ######
while (!$end) {
    my $current_date = time;    # current epoch date

    ## Empty cache of the List.pm module
    Sympa::List::init_list_cache();

    # Process grouped notifications
    Sympa::Alarm->instance->flush;

    ## List all tasks
    unless (Sympa::Task::list_tasks($spool_task)) {
        Sympa::send_notify_to_listmaster('*', 'intern_error',
            {'error' => "Failed to list task files in $spool_task"});
        $log->syslog('err', "Failed to list task files in %s", $spool_task);
        exit -1;
    }

    my %used_models;    # models for which a task exists
    foreach my $model (Sympa::Task::get_used_models()) {
        $used_models{$model} = 1;
    }

    ### creation of required tasks
    my %default_data = (
        'creation_date' =>
            $current_date,  # hash of datas necessary to the creation of tasks
        'execution_date' => 'execution_date'
    );

    ## global tasks
    foreach my $key (keys %global_models) {
        unless ($used_models{$global_models{$key}}) {
            if ($Conf::Conf{$key}) {
                # hash of datas necessary to the creation of tasks
                my %data = %default_data;
                create($current_date, '', $global_models{$key},
                    $Conf::Conf{$key}, \%data);
                $used_models{$1} = 1;    #!!!FIXME FIXME FIXME!!!
            }
        }
    }

    # list tasks
    foreach my $robot (Sympa::List::get_robots()) {
        my $all_lists = Sympa::List::get_lists($robot);
        last if $end;

        foreach my $list (@{$all_lists || []}) {
            my %data = %default_data;

            $data{'list'} = {
                'name'  => $list->{'name'},
                'robot' => $list->{'domain'}
            };

            my %used_list_models;    # stores which models already have a task
            foreach (@list_models) { $used_list_models{$_} = undef; }

            foreach
                my $model (Sympa::Task::get_used_models($list->get_list_id()))
            {
                $used_list_models{$model} = 1;
            }

            foreach my $model (@list_models) {
                unless ($used_list_models{$model}) {
                    my $model_task_parameter = "$model" . '_task';

                    if ($model eq 'sync_include') {
                        next
                            unless ($list->has_include_data_sources()
                            && ($list->{'admin'}{'status'} eq 'open'));

                        create($current_date, 'INIT', $model, 'ttl', \%data);

                    } elsif (defined $list->{'admin'}{$model_task_parameter}
                        && defined $list->{'admin'}{$model_task_parameter}
                        {'name'}
                        && ($list->{'admin'}{'status'} eq 'open')) {

                        create($current_date, '', $model,
                            $list->{'admin'}{$model_task_parameter}{'name'},
                            \%data);
                    }
                }
            }
        }
    }
    last if $end;

    ## Execute existing tasks
    ## List all tasks
    unless (Sympa::Task::list_tasks($spool_task)) {
        Sympa::send_notify_to_listmaster('*', 'intern_error',
            {'error' => "Failed to list task files in $spool_task"});
        $log->syslog('err', "Failed to list task files in %s", $spool_task);
        exit -1;
    }

    ## processing of tasks anterior to the current date
    $log->syslog('debug3',
        'Processing of tasks anterior to the current date');
    foreach my $task (Sympa::Task::get_task_list()) {
        last if $end;

        my $task_file = $task->{'filepath'};

        $log->syslog('debug3', 'Procesing %s', $task_file);
        last unless ($task->{'date'} < $current_date);
        if ($task->{'object'} ne '_global') {    # list task
            my $list = $task->{'list_object'};

            ## Skip closed lists
            unless (defined $list && ($list->{'admin'}{'status'} eq 'open')) {
                $log->syslog('notice',
                    'Removing task file %s because the list is not opened',
                    $task_file);
                unless (unlink $task_file) {
                    $log->syslog('err', 'Unable to remove task file %s: %m',
                        $task_file);
                    next;
                }
                next;
            }

            ## Skip if parameter is not defined
            if ($task->{'model'} eq 'sync_include') {
                unless ($list->{'admin'}{'status'} eq 'open') {
                    $log->syslog('notice', 'Removing task file %s',
                        $task_file);
                    unless (unlink $task_file) {
                        $log->syslog('err',
                            'Unable to remove task file %s: %m', $task_file);
                        next;
                    }
                    next;
                }
            } else {
                unless (defined $list->{'admin'}{$task->{'model'}}
                    && defined $list->{'admin'}{$task->{'model'}}{'name'}) {
                    $log->syslog('notice', 'Removing task file %s',
                        $task_file);
                    unless (unlink $task_file) {
                        $log->syslog('err',
                            'Unable to remove task file %s: %m', $task_file);
                        next;
                    }
                    next;
                }
            }
        }
        execute($task);
    }

    sleep 60;

    ## Free zombie sendmail processes
    #Sympa::Process->instance->reap_child;
}

# Purge grouped notifications
Sympa::Alarm->instance->flush(purge => 1);

$log->syslog('notice', 'Task_Manager exited normally due to signal');
$process->remove_pid(final => 1);

exit(0);

####### SUBROUTINES #######

## task creations
sub create {

    my $date         = shift;
    my $label        = shift;
    my $model        = shift;
    my $model_choice = shift;
    my $Rdata        = shift;

    $log->syslog('debug2',
        "create date : $date label : $label model $model : $model_choice Rdata :$Rdata"
    );

    my $task_file;
    my $list_name;
    my $robot;
    my $object;
    if (defined $Rdata->{'list'}) {
        $list_name = $Rdata->{'list'}{'name'};
        $robot     = $Rdata->{'list'}{'robot'};
        $task_file = "$spool_task/$date.$label.$model.$list_name\@$robot";
        $object    = 'list';
    } else {
        $object = '_global';
        $task_file =
              $spool_task . '/' 
            . $date . '.' 
            . $label . '.' 
            . $model . '.'
            . $object;
    }

    ## model recovery
    my $model_file;
    my $model_name = $model . '.' . $model_choice . '.' . 'task';

    $log->syslog('notice', 'Creation of %s', $task_file);

    # for global model
    if ($object eq '_global') {
        unless (
            $model_file = Sympa::search_fullpath(
                '*', $model_name, subdir => 'global_task_models'
            )
            ) {
            $log->syslog('err', 'Unable to find %s, creation aborted',
                $model_name);
            return undef;
        }
    }

    # for a list
    if ($object eq 'list') {
        my $list = Sympa::List->new($list_name, $robot);

        $Rdata->{'list'}{'ttl'} = $list->{'admin'}{'ttl'};

        unless (
            $model_file = Sympa::search_fullpath(
                $list, $model_name, subdir => 'list_task_models'
            )
            ) {
            $log->syslog('err',
                "error : unable to find $model_name, for list $list_name creation aborted"
            );
            return undef;
        }
    }

    $log->syslog('notice', 'With model %s', $model_file);

    ## creation
    open(TASK, ">$task_file");
    my $tt2 = Template->new(
        {   'START_TAG' => quotemeta('['),
            'END_TAG'   => quotemeta(']'),
            'ABSOLUTE'  => 1
        }
    );
    unless (defined $tt2 && $tt2->process($model_file, $Rdata, \*TASK)) {
        $log->syslog('err', 'Failed to parse task template "%s": %s',
            $model_file, $tt2->error());
    }
    #&parser::parse_tpl($Rdata, $model_file, \*TASK);
    close(TASK);

    if (!check($task_file)) {
        $log->syslog('err',
            "error : syntax error in $task_file, you should check $model_file"
        );
        unlink($task_file)
            ? $log->syslog('notice', '%s deleted',          $task_file)
            : $log->syslog('err',    'Unable to delete %s', $task_file);
        return undef;
    }
    return 1;
}

### SYNTAX CHECKING SUBROUTINES ###

## check the syntax of a task
sub check {

    my $task_file = shift;    # the task to check

    $log->syslog('debug2', '(%s)', $task_file);
    my %result;               # stores the result of the chk_line subroutine
    my $lnb = 0;              # line number
    my %used_labels;          # list of labels used as parameter in commands
    my %labels;               # list of declared labels
    my %used_vars;            # list of vars used as parameter in commands
    my %vars;                 # list of declared vars

    unless (open(TASK, $task_file)) {
        $log->syslog('err', 'Unable to read %s, checking is impossible',
            $task_file);
        return undef;
    }

    while (<TASK>) {

        chomp;

        $lnb++;

        next if ($_ =~ /^\s*\#/);
        unless (chk_line($_, \%result)) {
            $log->syslog('err', 'Error at line %s: %s', $lnb, $_);
            $log->syslog('err', '%s', $result{'error'});
            return undef;
        }

        if ($result{'nature'} eq 'assignment') {
            if (chk_cmd(
                    $result{'command'},    $lnb,
                    $result{'Rarguments'}, \%used_labels,
                    \%used_vars
                )
                ) {
                $vars{$result{'var'}} = 1;
            } else {
                return undef;
            }
        }

        if ($result{'nature'} eq 'command') {
            return undef
                unless (
                chk_cmd(
                    $result{'command'},    $lnb,
                    $result{'Rarguments'}, \%used_labels,
                    \%used_vars
                )
                );
        }

        $labels{$result{'label'}} = 1 if ($result{'nature'} eq 'label');

    }

    # are all labels used ?
    foreach my $label (keys %labels) {
        $log->syslog('debug3', 'Warning: Label %s exists but is not used',
            $label)
            unless ($used_labels{$label});
    }

    # do all used labels exist ?
    foreach my $label (keys %used_labels) {
        unless ($labels{$label}) {
            $log->syslog('err', 'Label %s is used but does not exist',
                $label);
            return undef;
        }
    }

    # are all variables used ?
    foreach my $var (keys %vars) {
        $log->syslog('notice', 'Warning: Var %s exists but is not used', $var)
            unless ($used_vars{$var});
    }

    # do all used variables exist ?
    foreach my $var (keys %used_vars) {
        unless ($vars{$var}) {
            $log->syslog('err', 'Var %s is used but does not exist', $var);
            return undef;
        }
    }

    return 1;
}

## check a task line
sub chk_line {

    my $line = $_[0];
    my $Rhash =
        $_[1];    # will contain nature of line (label, command, error...)

    ## just in case...
    chomp $line;

    $log->syslog('debug2', '(%s, %s)', $line, $Rhash->{'nature'});

    $Rhash->{'nature'} = undef;

    # empty line
    if (!$line) {
        $Rhash->{'nature'} = 'empty line';
        return 1;
    }

    # comment
    if ($line =~ /^\s*\#.*/) {
        $Rhash->{'nature'} = 'comment';
        return 1;
    }

    # title
    if ($line =~ /^\s*title\...\s*(.*)\s*/i) {
        $Rhash->{'nature'} = 'title';
        $Rhash->{'title'}  = $1;
        return 1;
    }

    # label
    if ($line =~ /^\s*\/\s*(.*)/) {
        $Rhash->{'nature'} = 'label';
        $Rhash->{'label'}  = $1;
        return 1;
    }

    # command
    if ($line =~ /^\s*(\w+)\s*\((.*)\)\s*/i) {

        my $command = lc($1);
        my @args = split(/,/, $2);
        foreach (@args) { s/\s//g; }

        unless ($commands{$command}) {
            $Rhash->{'nature'} = 'error';
            $Rhash->{'error'}  = "unknown command $command";
            return 0;
        }

        $Rhash->{'nature'}  = 'command';
        $Rhash->{'command'} = $command;

        # arguments recovery. no checking of their syntax !!!
        $Rhash->{'Rarguments'} = \@args;
        return 1;
    }

    # assignment
    if ($line =~ /^\s*(@\w+)\s*=\s*(.+)/) {

        my %hash2;
        chk_line($2, \%hash2);
        unless ($asgn_commands{$hash2{'command'}}) {
            $Rhash->{'nature'} = 'error';
            $Rhash->{'error'}  = "non valid assignment $2";
            return 0;
        }
        $Rhash->{'nature'}     = 'assignment';
        $Rhash->{'var'}        = $1;
        $Rhash->{'command'}    = $hash2{'command'};
        $Rhash->{'Rarguments'} = $hash2{'Rarguments'};
        return 1;
    }

    $Rhash->{'nature'} = 'error';
    $Rhash->{'error'}  = 'syntax error';
    return 0;
}

## check the arguments of a command
sub chk_cmd {

    my $cmd          = $_[0];    # command name
    my $lnb          = $_[1];    # line number
    my $Rargs        = $_[2];    # argument list
    my $Rused_labels = $_[3];
    my $Rused_vars   = $_[4];

    $log->syslog('debug2', '(%s, %d, %s)', $cmd, $lnb, join(',', @{$Rargs}));

    if (defined $commands{$cmd}) {

        my @expected_args = @{$commands{$cmd}};
        my @args          = @{$Rargs};

        unless ($#expected_args == $#args) {
            $log->syslog('err',
                'Error at line %s: wrong number of arguments for %s',
                $lnb, $cmd);
            $log->syslog('err',
                'Args = @args; expected_args = @expected_args');
            return undef;
        }

        foreach (@args) {

            undef my $error;
            my $regexp = $expected_args[0];
            shift(@expected_args);

            if ($regexp eq 'date') {
                $error = 1
                    unless ((/^$date_arg_regexp1$/i)
                    or (/^$date_arg_regexp2$/i)
                    or (/^$date_arg_regexp3$/i));
            } elsif ($regexp eq 'delay') {
                $error = 1 unless (/^$delay_regexp$/i);
            } elsif ($regexp eq 'var') {
                $error = 1 unless (/^$var_regexp$/i);
            } elsif ($regexp eq 'subarg') {
                $error = 1 unless (/^$subarg_regexp$/i);
            } else {
                $error = 1 unless (/^$regexp$/i);
            }

            if ($error) {
                $log->syslog('err',
                    'Error at line %s: argument %s is not valid',
                    $lnb, $_);
                return undef;
            }

            $Rused_labels->{$args[1]} = 1 if ($cmd eq 'next' && ($args[1]));
            $Rused_vars->{$args[0]} = 1 if ($var_commands{$cmd});
        }
    }
    return 1;
}

### TASK EXECUTION SUBROUTINES ###

sub execute {

    my $task      = shift;
    my $task_file = $task->{'filepath'};    # task to execute

    my %result;    # stores the result of the chk_line subroutine
    my %vars;      # list of task vars
    my $lnb = 0;   # line number

    $log->syslog('notice', 'Running task %s, line %d with vars %s)',
        $task_file, $lnb, join('/', %vars));

    unless (open(TASK, $task_file)) {
        $log->syslog('err', 'Can\'t read the task %s', $task_file);
        return undef;
    }

    my $label = $task->{'label'};
    return undef if ($label eq 'ERROR');

    $log->syslog('debug2', '* execution of the task %s', $task_file);
    if (length $label) {
        while (<TASK>) {
            chomp;
            $lnb++;
            chk_line($_, \%result);
            next unless defined $result{'label'};

            last if $result{'label'} eq $label;
        }
    }

    # execution
    my $status;
    while (<TASK>) {

        chomp;
        $lnb++;

        unless (chk_line($_, \%result)) {
            $log->syslog('err', '%s', $result{'error'});
            return undef;
        }

        # processing of the assignments
        if ($result{'nature'} eq 'assignment') {
            $status = $vars{$result{'var'}} =
                cmd_process($result{'command'}, $result{'Rarguments'}, $task,
                \%vars, $lnb);
            last unless defined($status);
        }

        # processing of the commands
        if ($result{'nature'} eq 'command') {
            $status =
                cmd_process($result{'command'}, $result{'Rarguments'}, $task,
                \%vars, $lnb);
            last unless (defined($status) && $status >= 0);
        }
    }

    close(TASK);

    unless (defined $status) {
        $log->syslog('err', 'Error while processing task, removing %s',
            $task_file);
        unless (unlink($task_file)) {
            $log->syslog('err', 'Unable to remove task file %s: %m',
                $task_file);
            return undef;
        }
        return undef;
    }
    unless ($status >= 0) {
        $log->syslog('notice', 'The task %s is now useless. Removing it',
            $task_file);
        unless (unlink($task_file)) {
            $log->syslog('err', 'Unable to remove task file %s: %m',
                $task_file);
            return undef;
        }
    }

    return 1;
}

sub cmd_process {

    my $command    = $_[0];    # command name
    my $Rarguments = $_[1];    # command arguments
    my $task       = $_[2];    # task
    my $Rvars      = $_[3];    # variable list of the task
    my $lnb        = $_[4];    # line number

    my $task_file = $task->{'filepath'};

    $log->syslog('debug2', '(%s, %s, %d)', $command, $task_file, $lnb);

    # building of %context
    my %context = ('line_number' => $lnb);

    $log->syslog(
        'debug2',
        'Current task: %s',
        join(':', map { (defined $_) ? $_ : '' } (%$task))
    );

    # regular commands
    return stop($task, \%context) if ($command eq 'stop');
    return next_cmd($task, $Rarguments, \%context) if ($command eq 'next');
    return create_cmd($task, $Rarguments, \%context)
        if ($command eq 'create');
    return exec_cmd($task, $Rarguments) if ($command eq 'exec');
    return expire_bounce($task, $Rarguments, \%context)
        if ($command eq 'expire_bounce');
    return purge_user_table($task, \%context)
        if ($command eq 'purge_user_table');
    return purge_logs_table($task, \%context)
        if ($command eq 'purge_logs_table');
    return purge_session_table($task, \%context)
        if ($command eq 'purge_session_table');
    return purge_spools($task, \%context) if $command eq 'purge_spools';
    return purge_tables($task, \%context) if ($command eq 'purge_tables');
    return purge_one_time_ticket_table($task, \%context)
        if ($command eq 'purge_one_time_ticket_table');
    return sync_include($task, \%context) if ($command eq 'sync_include');
    return purge_orphan_bounces($task, \%context)
        if ($command eq 'purge_orphan_bounces');
    return eval_bouncers($task, \%context) if ($command eq 'eval_bouncers');
    return process_bouncers($task, \%context)
        if ($command eq 'process_bouncers');

    # commands which use a variable
    return send_msg($task, $Rarguments, $Rvars, \%context)
        if ($command eq 'send_msg');
    return rm_file($task, $Rarguments, $Rvars, \%context)
        if ($command eq 'rm_file');

    # commands which return a variable
    return select_subs($task, $Rarguments, \%context)
        if ($command eq 'select_subs');

    # commands which return and use a variable
    return delete_subs_cmd($task, $Rarguments, $Rvars, \%context)
        if ($command eq 'delete_subs');
}

### command subroutines ###

# remove files whose name is given in the key 'file' of the hash
sub rm_file {

    my ($task, $Rarguments, $Rvars, $context) = @_;

    my @tab = @{$Rarguments};
    my $var = $tab[0];

    foreach my $key (keys %{$Rvars->{$var}}) {
        my $file = $Rvars->{$var}{$key}{'file'};
        next unless ($file);
        unless (unlink($file)) {
            error($task->{'filepath'},
                "error in rm_file command : unable to remove $file");
            return undef;
        }
    }

    return 1;
}

sub stop {

    my ($task, $context) = @_;
    my $task_file = $spool_task . '/' . $task->{'filename'};

    $log->syslog('notice', '%s: stop %s', $context->{'line_number'},
        $task_file);

    unlink($task_file)
        ? $log->syslog('notice', '--> %s deleted', $task_file)
        : error($task_file,
        "error in stop command : unable to delete task file");

    return 0;
}

sub send_msg {

    my ($task, $Rarguments, $Rvars, $context) = @_;

    my @tab      = @{$Rarguments};
    my $template = $tab[1];
    my $var      = $tab[0];

    $log->syslog(
        'notice',
        'Line %s: send_msg (@{%s})',
        $context->{'line_number'}, $Rarguments
    );

    if ($task->{'object'} eq '_global') {

        foreach my $email (keys %{$Rvars->{$var}}) {
            $log->syslog('notice', '--> message sent to %s', $email);
            unless ($log_only) {
                unless (
                    Sympa::send_file(
                        '*', $template, $email, $Rvars->{$var}{$email}
                    )
                    ) {
                    $log->syslog('notice', 'Unable to send template %s to %s',
                        $template, $email);
                }
            }
        }
    } else {
        my $list = $task->{'list_object'};

        foreach my $email (keys %{$Rvars->{$var}}) {
            $log->syslog('notice', '--> message sent to %s', $email);
            unless ($log_only) {
                unless (
                    Sympa::send_file(
                        $list, $template, $email, $Rvars->{$var}{$email}
                    )
                    ) {
                    $log->syslog('notice', 'Unable to send template %s to %s',
                        $template, $email);
                }
            }
        }
    }
    return 1;
}

sub next_cmd {

    my ($task, $Rarguments, $context) = @_;

    my @tab = @{$Rarguments};
    # conversion of the date argument into epoch format
    my $date = Sympa::Tools::Time::epoch_conv($tab[0], $task->{'date'});
    my $label = $tab[1];

    $log->syslog('notice',
        "line $context->{'line_number'} of $task->{'model'} : next ($date, $label)"
    );

    my $listname = $task->{'object'};
    my $model    = $task->{'model'};
    my $filename = $task->{'filepath'};

    ## Determine type
    my ($type, $model_choice);
    my %data = (
        'creation_date'  => $task->{'date'},
        'execution_date' => 'execution_date'
    );
    if ($listname eq '_global') {
        $type = '_global';
        foreach my $key (keys %global_models) {
            if ($global_models{$key} eq $model) {
                $model_choice = $Conf::Conf{$key};
                last;
            }
        }
    } else {
        $type = 'list';
        my $list = $task->{'list_object'};
        $data{'list'}{'name'}  = $list->{'name'};
        $data{'list'}{'robot'} = $list->{'domain'};

        if ($model eq 'sync_include') {
            $data{'list'}{'ttl'} = $list->{'admin'}{'ttl'};
            $model_choice = 'ttl';
        } else {
            unless (defined $list->{'admin'}{"$model\_task"}) {
                error($filename,
                    "List $list->{'name'} no more require $model task");
                return undef;
            }

            $model_choice = $list->{'admin'}{"$model\_task"}{'name'};
        }
    }

    unless (create($date, $tab[1], $model, $model_choice, \%data)) {
        error($filename,
            "error in create command : creation subroutine failure");
        return undef;
    }

#    my $new_task = "$date.$label.$name[2].$name[3]";
    my $human_date = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime $date);
#    my $new_task_file = "$spool_task/$new_task";
#    unless (rename ($filename, $new_task_file)) {
#        error ($filename,
#        "error in next command : unable to rename task file into $new_task");
#        return undef;
#    }
    unless (unlink($filename)) {
        error($filename,
            "error in next command : unable to remove task file $filename");
        return undef;
    }

    $log->syslog('notice', '--> new task %s (%s)', $model, $human_date);

    return 0;
}

sub select_subs {

    my ($task, $Rarguments, $context) = @_;

    my @tab       = @{$Rarguments};
    my $condition = $tab[0];

    $log->syslog(
        'debug2',
        'Line %s: select_subs (%s)',
        $context->{'line_number'}, $condition
    );
    $condition =~ /(\w+)\(([^\)]*)\)/;
    if ($2) {    # conversion of the date argument into epoch format
        my $date = Sympa::Tools::Time::epoch_conv($2, $task->{'date'});
        $condition = "$1($date)";
    }

    my @users;        # the subscribers of the list
    my %selection;    # hash of subscribers who match the condition
    my $list = $task->{'list_object'};

    for (
        my $user = $list->get_first_list_member();
        $user;
        $user = $list->get_next_list_member()
        ) {
        push(@users, $user);
    }

    # parameter of subroutine Sympa::Scenario::verify
    my $verify_context = {
        'sender'      => 'nobody',
        'email'       => 'nobody',
        'remote_host' => 'unknown_host',
        'listname'    => $task->{'object'}
    };

    my $new_condition =
        $condition;    # necessary to the older & newer condition rewriting
    # loop on the subscribers of $list_name
    foreach my $user (@users) {

        # AF : voir 'update' $log->syslog ('notice', "date $user->{'date'} & update $user->{'update'}");
        # condition rewriting for older and newer
        $new_condition = "$1($user->{'update_date'}, $2)"
            if ($condition =~ /(older|newer)\((\d+)\)/);

        if (Sympa::Scenario::verify($verify_context, $new_condition) == 1) {
            $selection{$user->{'email'}} = undef;
            $log->syslog('notice', '--> user %s has been selected',
                $user->{'email'});
        }
    }

    return \%selection;
}

sub delete_subs_cmd {

    my ($task, $Rarguments, $Rvars, $context) = @_;

    my @tab = @{$Rarguments};
    my $var = $tab[0];

    $log->syslog(
        'notice',
        'Line %s: delete_subs (%s)',
        $context->{'line_number'}, $var
    );

    my $list = $task->{'list_object'};
    my %selection;    # hash of subscriber emails who are successfully deleted

    foreach my $email (keys %{$Rvars->{$var}}) {
        $log->syslog('notice', '%s', $email);
        my $result = Sympa::Scenario::request_action(
            $list, 'del', 'smime',
            {   'sender' => $Conf::Conf{'listmaster'},    #FIXME
                'email'  => $email,
            }
        );
        my $action;
        $action = $result->{'action'} if (ref($result) eq 'HASH');
        if ($action =~ /reject/i) {
            error($task->{'filepath'},
                "error in delete_subs command : deletion of $email not allowed"
            );
        } else {
            my $u = $list->delete_list_member(
                users     => [$email],
                operation => 'auto_del'
            ) unless $log_only;
            $log->syslog('notice', '--> %s deleted', $email);
            $selection{$email} = {};
        }
    }

    return \%selection;
}

sub create_cmd {

    my ($task, $Rarguments, $context) = @_;

    my @tab          = @{$Rarguments};
    my $arg          = $tab[0];
    my $model        = $tab[1];
    my $model_choice = $tab[2];

    $log->syslog('notice',
        "line $context->{'line_number'} : create ($arg, $model, $model_choice)"
    );

    # recovery of the object type and object
    my $type;
    my $object;
    if ($arg =~ /$subarg_regexp/) {
        $type   = $1;
        $object = $3;
    } else {
        error($task->{'filepath'},
            "error in create command : don't know how to create $arg");
        return undef;
    }

    # building of the data hash necessary to the create subroutine
    my %data = (
        'creation_date'  => $task->{'date'},
        'execution_date' => 'execution_date'
    );

    if ($type eq 'list') {
        my $list = Sympa::List->new($object);
        $data{'list'}{'name'} = $list->{'name'};
    }
    $type = '_global';
    unless (create($task->{'date'}, '', $model, $model_choice, \%data)) {
        error($task->{'filepath'},
            "error in create command : creation subroutine failure");
        return undef;
    }

    return 1;
}

sub exec_cmd {

    my ($task, $Rarguments, $context) = @_;

    my @tab  = @{$Rarguments};
    my $file = $tab[0];

    $log->syslog(
        'notice',
        'Line %s: exec (%s)',
        $context->{'line_number'}, $file
    );
    system($file);

    return 1;
}

sub purge_logs_table {
    $log->syslog('debug2', '(%s, %s)', @_);
    my ($task, $context) = @_;

    #my $execution_date = $task->{'date'};

    unless (_db_log_del()) {
        $log->syslog('err', 'Failed to delete logs');
        return undef;
    }

    $log->syslog('notice', 'Logs purged');

    if ($log->aggregate_stat) {
        $log->syslog('notice', 'Stats aggregated');
    }

    return 1;
}

# Deletes logs in RDBMS.
# If a log is older than $list->get_latest_distribution_date() - $delay
# expire the log.
sub _db_log_del {
    my ($exp, $date);

    my $sdm = Sympa::DatabaseManager->instance;

    $exp = Conf::get_robot_conf('*', 'logs_expiration_period');
    $date = time - ($exp * 31 * 24 * 60 * 60);
    unless (
        $sdm
        and $sdm->do_prepared_query(
            q{DELETE FROM logs_table
              WHERE date_logs <= ?},
            $date
        )
        ) {
        $log->syslog('err',
            'Unable to delete db_log entry from the database');
        return undef;
    }

    $exp = Conf::get_robot_conf('*', 'stats_expiration_period');
    $date = time - ($exp * 31 * 24 * 60 * 60);
    unless (
        $sdm->do_prepared_query(
            q{DELETE FROM stat_table
              WHERE date_stat <= ?},
            $date
        )
        ) {
        $log->syslog('err',
            'Unable to delete db_log entry from the database');
        return undef;
    }
    unless (
        $sdm->do_prepared_query(
            q{DELETE FROM stat_counter_table
              WHERE end_date_counter <= ?},
            $date
        )
        ) {
        $log->syslog('err',
            'Unable to delete db_log entry from the database');
        return undef;
    }

    return 1;
}

## remove sessions from session_table if older than $Conf::Conf{'session_table_ttl'}
sub purge_session_table {

    $log->syslog('info', '');
    my $removed = Sympa::Session::purge_old_sessions('*');
    unless (defined $removed) {
        $log->syslog('err', 'Failed to remove old sessions');
        return undef;
    }
    $log->syslog('notice', '%s row removed in session_table', $removed);
    return 1;
}

# Remove messages from spools if older than duration given by configuration.
sub purge_spools {
    # Expiring bad messages in incoming spools and archive spool.
    foreach my $queue (qw(queue queueautomatic queuebounce queueoutgoing)) {
        my $directory   = $Conf::Conf{$queue} . '/bad';
        my $clean_delay = $Conf::Conf{'clean_delay_' . $queue};
        if (-e $directory) {
            _clean_spool($directory, $clean_delay);
        }
    }

    # Expiring bad messages in digest spool.
    if (opendir my $dh, $Conf::Conf{'queuedigest'}) {
        my $base_dir = $Conf::Conf{'queuedigest'};
        my @dirs = grep { !/\A\./ and -d $base_dir . '/' . $_ } readdir $dh;
        closedir $dh;
        foreach my $subdir (@dirs) {
            my $directory   = $base_dir . '/' . $subdir . '/bad';
            my $clean_delay = $Conf::Conf{'clean_delay_queuedigest'};
            if (-e $directory) {
                _clean_spool($directory, $clean_delay);
            }
        }
    }

    # Expiring bad packets and messages in bulk spool.
    foreach my $subdir (qw(pct msg)) {
        my $directory   = $Conf::Conf{'queuebulk'} . '/bad/' . $subdir;
        my $clean_delay = $Conf::Conf{'clean_delay_queuebulk'};
        if (-e $directory) {
            _clean_spool($directory, $clean_delay);
        }
    }

    # Expiring moderation spools except mod, topic spool and temporary files.
    foreach my $queue (
        qw(queueauth queueautomatic queuesubscribe queuetopic tmpdir)) {
        my $directory   = $Conf::Conf{$queue};
        my $clean_delay = $Conf::Conf{'clean_delay_' . $queue};
        if (-e $directory) {
            _clean_spool($directory, $clean_delay);
        }
    }

    # Expiring mod spool.
    my $modqueue = $Conf::Conf{'queuemod'};
    if (opendir my $dh, $modqueue) {
        my @qfiles = sort readdir $dh;
        closedir $dh;
        foreach my $i (@qfiles) {
            next if $i =~ /\A[.]/;
            next unless -f $modqueue . '/' . $i;

            $i =~ /\A(.+)_[.\w]+\z/;
            my $list = Sympa::List->new($1, '*', {just_try => 1}) if $1;
            my $moddelay;
            if (ref $list eq 'Sympa::List') {
                $moddelay = $list->{'admin'}{'clean_delay_queuemod'};
            } else {
                $moddelay = $Conf::Conf{'clean_delay_queuemod'};
            }
            if ($moddelay) {
                my $mtime =
                    Sympa::Tools::File::get_mtime($modqueue . '/' . $i);
                if ($mtime < time - $moddelay * 86400) {
                    unlink($modqueue . '/' . $i);
                    $log->syslog('notice',
                        'Deleting unmoderated message %s, too old', $i);
                }
            }
        }
    }

    # Expiring formatted held messages.
    if (opendir my $dh, $Conf::Conf{'viewmail_dir'} . '/mod') {
        my $base_dir = $Conf::Conf{'viewmail_dir'} . '/mod';
        my @dirs = grep { !/\A\./ and -d $base_dir . '/' . $_ } readdir $dh;
        closedir $dh;
        foreach my $list_id (@dirs) {
            my $clean_delay;
            my $list = Sympa::List->new($list_id, '*', {just_try => 1});
            if (ref $list eq 'Sympa::List') {
                $clean_delay = $list->{'admin'}{'clean_delay_queuemod'};
            } else {
                $clean_delay = $Conf::Conf{'clean_delay_queuemod'};
            }
            my $directory = $base_dir . '/' . $list_id;
            if ($clean_delay and -e $directory) {
                _clean_spool($directory, $clean_delay);
            }
        }
    }

    # Removing messages in bulk spool with no more packet.
    my $pct_directory = $Conf::Conf{'queuebulk'} . '/pct';
    my $msg_directory = $Conf::Conf{'queuebulk'} . '/msg';
    if (opendir my $dh, $pct_directory) {
        my $msgpath;
        while ($msgpath = readdir $dh) {
            next if $msgpath =~ /\A\./;
            next unless -d $pct_directory . '/' . $msgpath;
            next
                if time - 3600 < Sympa::Tools::File::get_mtime(
                $pct_directory . '/' . $msgpath);

            # If packet directory is empty, remove message also.
            unlink($msg_directory . '/' . $msgpath)
                if rmdir($pct_directory . '/' . $msgpath);
        }
        closedir $dh;
    }

    return 1;
}

# Old name: tools::CleanSpool(), Sympa::Tools::File::CleanDir().
sub _clean_spool {
    $log->syslog('debug2', '(%s, %s)', @_);
    my ($directory, $clean_delay) = @_;

    return 1 unless $clean_delay;

    my $dh;
    unless (opendir $dh, $directory) {
        $log->syslog('err', 'Unable to open "%s" spool: %m', $directory);
        return undef;
    }
    my @qfile = sort grep { !/\A\.+\z/ and !/\Abad\z/ } readdir $dh;
    closedir $dh;

    my ($curlist, $moddelay);
    foreach my $f (@qfile) {
        if (Sympa::Tools::File::get_mtime("$directory/$f") <
            time - $clean_delay * 60 * 60 * 24) {
            if (-f "$directory/$f") {
                unlink("$directory/$f");
                $log->syslog('notice', 'Deleting old file %s',
                    "$directory/$f");
            } elsif (-d "$directory/$f") {
                unless (Sympa::Tools::File::remove_dir("$directory/$f")) {
                    $log->syslog('err', 'Cannot remove old directory %s: %m',
                        "$directory/$f");
                    next;
                }
                $log->syslog('notice', 'Deleting old directory %s',
                    "$directory/$f");
            }
        }
    }

    return 1;
}

## remove messages from bulkspool table when no more packet have any pointer
## to this message
sub purge_tables {
    $log->syslog('info', '');
    my $removed;

    $removed = 0;
    foreach my $robot (Sympa::List::get_robots()) {
        my $all_lists = Sympa::List::get_lists($robot);
        return 1 if $end;

        foreach my $list (@{$all_lists || []}) {
            my $tracking = Sympa::Tracking->new(context => $list);

            $removed +=
                $tracking->remove_message_by_period(
                $list->{'admin'}{'tracking'}{'retention_period'});
        }
    }
    $log->syslog('notice', "%s rows removed in tracking table", $removed);

    return 1;
}

## remove one time ticket table if older than $Conf::Conf{'one_time_ticket_table_ttl'}
sub purge_one_time_ticket_table {

    $log->syslog('info', '');
    my $removed = Sympa::Ticket::purge_old_tickets('*');
    unless (defined $removed) {
        $log->syslog('err', 'Failed to remove old tickets');
        return undef;
    }
    $log->syslog('notice', '%s row removed in one_time_ticket_table',
        $removed);
    return 1;
}

sub purge_user_table {
    my ($task, $Rarguments, $context) = @_;
    $log->syslog('debug2', '');

    my $sdm = Sympa::DatabaseManager->instance;

    my $time = time;

    # Marking super listmasters
    foreach my $l (Sympa::get_listmasters_email('*')) {
        unless (
            $sdm
            and $sdm->do_prepared_query(
                q{UPDATE user_table
                  SET last_active_date_user = ?
                  WHERE email_user = ?},
                $time, lc $l
            )
            ) {
            $log->syslog('err', 'Failed to check activity of users');
            return undef;
        }
    }
    # Marking per-robot listmasters.
    foreach my $robot_id (Sympa::List::get_robots()) {
        foreach my $l (Sympa::get_listmasters_email($robot_id)) {
            unless (
                $sdm->do_prepared_query(
                    q{UPDATE user_table
                      SET last_active_date_user = ?
                      WHERE email_user = ?},
                    $time, lc $l
                )
                ) {
                $log->syslog('err', 'Failed to check activity of users');
                return undef;
            }
        }
    }
    # Marking new users, owners/editors and subscribers.
    unless (
        $sdm->do_prepared_query(
            q{UPDATE user_table
              SET last_active_date_user = ?
              WHERE last_active_date_user IS NULL
              OR EXISTS (
                SELECT 1
                FROM admin_table
                WHERE admin_table.user_admin = user_table.email_user
              )
              OR EXISTS (
                SELECT 1
                FROM subscriber_table
                WHERE subscriber_table.user_subscriber = user_table.email_user
              )},
            $time
        )
        ) {
        $log->syslog('err', 'Failed to check activity of users');
        return undef;
    }

    # Look for unused entries.
    my @purged_users;
    my $sth;
    unless (
        $sth = $sdm->do_prepared_query(
            q{SELECT email_user
              FROM user_table
              WHERE last_active_date_user IS NOT NULL AND
                    last_active_date_user < ?},
            $time
        )
        ) {
        $log->syslog('err', 'Failed to get inactive users');
        return undef;
    }
    @purged_users =
        grep {$_} map { $_->[0] } @{$sth->fetchall_arrayref || []};
    $sth->finish;

    # Purge unused entries.
    foreach my $email (@purged_users) {
        my $user = Sympa::User->new($email);
        next unless $user;

        unless ($user->expire) {
            $log->syslog('err', 'Failed to purge inactive user %s', $user);
            return undef;
        } else {
            $log->syslog('info', 'User %s was expired', $user);
        }
    }

    return scalar @purged_users;
}

## Subroutine which remove bounced message of no-more known users
sub purge_orphan_bounces {
    my ($task, $context) = @_;

    $log->syslog('info', '');

    my $all_lists = Sympa::List::get_lists('*');
    foreach my $list (@{$all_lists || []}) {
        # First time: loading DB entries into %bounced_users,
        # hash {'bounced address' => 1}
        my %bounced_users;

        for (
            my $user_ref = $list->get_first_bouncing_list_member();
            $user_ref;
            $user_ref = $list->get_next_bouncing_list_member()
            ) {
            my $user_id = $user_ref->{'email'};
            $bounced_users{Sympa::Tools::Text::escape_chars($user_id)} = 1;
        }

        my $bounce_dir = $list->get_bounce_dir();
        unless (-d $bounce_dir) {
            $log->syslog('notice', 'No bouncing subscribers in list %s',
                $list);
            next;
        }

        # Then reading Bounce directory & compare with %bounced_users
        my $dh;
        unless (opendir $dh, $bounce_dir) {
            $log->syslog('err', 'Error while opening bounce directory %s',
                $bounce_dir);
            return undef;
        }

        # Finally removing orphan files
        my $marshalled;
        while ($marshalled = readdir $dh) {
            my $metadata =
                Sympa::Spool::unmarshal_metadata($bounce_dir, $marshalled,
                qr/\A([^\s\@]+\@[\w\.\-*]+?)(?:_(\w+))?\z/,
                [qw(recipient envid)]);
            next unless $metadata;
            # Skip <email>_<envid> which is used by tracking feature.
            next if defined $metadata->{envid};

            unless ($bounced_users{$marshalled}) {
                $log->syslog('info',
                    'Removing orphan Bounce for user %s in list %s',
                    $marshalled, $list);
                unless (unlink($bounce_dir . '/' . $marshalled)) {
                    $log->syslog('err', 'Error while removing file %s/%s',
                        $bounce_dir, $marshalled);
                }
            }
        }

        closedir $dh;
    }
    return 1;
}

# If a bounce is older than $list->get_latest_distribution_date() - $delay
# expire the bounce.
sub expire_bounce {
    $log->syslog('debug2', '(%s, %s, %s)', @_);
    #FXIME: May this variable be set in to task model ?
    my ($task, $Rarguments, $context) = @_;

    my @tab   = @{$Rarguments};
    my $delay = $tab[0];

    my $all_lists = Sympa::List::get_lists('*');
    foreach my $list (@{$all_lists || []}) {
        my $listname = $list->{'name'};

        # the reference date is the date until which we expire bounces in
        # second
        # the latest_distribution_date is the date of last distribution #days
        # from 01 01 1970

        unless ($list->get_latest_distribution_date()) {
            $log->syslog(
                'debug2',
                'Bounce expiration: skipping list %s because could not get latest distribution date',
                $listname
            );
            next;
        }
        my $refdate =
            (($list->get_latest_distribution_date() - $delay) * 3600 * 24);

        for (
            my $u = $list->get_first_bouncing_list_member();
            $u;
            $u = $list->get_next_bouncing_list_member()
            ) {
            $u->{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/;
            $u->{'last_bounce'} = $2;
            if ($u->{'last_bounce'} < $refdate) {
                my $email = $u->{'email'};

                unless ($list->is_list_member($email)) {
                    $log->syslog('info', '%s not subscribed', $email);
                    next;
                }

                unless (
                    $list->update_list_member(
                        $email,
                        bounce         => undef,
                        bounce_address => undef
                    )
                    ) {
                    $log->syslog('info', 'Failed update database for %s',
                        $email);
                    next;
                }
                my $escaped_email = Sympa::Tools::Text::escape_chars($email);

                my $bounce_dir = $list->get_bounce_dir();

                unless (unlink $bounce_dir . '/' . $escaped_email) {
                    $log->syslog(
                        'info',
                        'Failed deleting %s',
                        $bounce_dir . '/' . $escaped_email
                    );
                    next;
                }
                $log->syslog(
                    'info',
                    'Expire bounces for subscriber %s of list %s (last distribution %s, last bounce %s)',
                    $email,
                    $listname,
                    POSIX::strftime(
                        "%Y-%m-%d",
                        localtime(
                            $list->get_latest_distribution_date() * 3600 * 24
                        )
                    ),
                    POSIX::strftime(
                        "%Y-%m-%d", localtime($u->{'last_bounce'})
                    )
                );
            }
        }
    }

    # Expiring formatted bounce messages.
    if (opendir my $dh, $Conf::Conf{'viewmail_dir'} . '/bounce') {
        my $base_dir = $Conf::Conf{'viewmail_dir'} . '/bounce';
        my @dirs = grep { !/\A\./ and -d $base_dir . '/' . $_ } readdir $dh;
        closedir $dh;
        foreach my $list_id (@dirs) {
            my $directory = $base_dir . '/' . $list_id;
            if (-e $directory) {
                _clean_spool($directory, $delay);
            }
        }
    }

    return 1;
}

# Removed because not yet fully implemented.  See r11771.
#sub chk_cert_expiration;

# Removed becuase not yet fully implemented.  See r11771.
#sub update_crl;

## Subroutine for bouncers evaluation:
# give a score for each bouncing user
sub eval_bouncers {
    #################
    my ($task, $context) = @_;

    my $all_lists = Sympa::List::get_lists('*');
    foreach my $list (@{$all_lists || []}) {
        my $listname     = $list->{'name'};
        my $list_traffic = {};

        $log->syslog('info', '(%s)', $listname);

        ## Analizing file Msg-count and fill %$list_traffic
        unless (open(COUNT, $list->{'dir'} . '/msg_count')) {
            $log->syslog('debug',
                '** Could not open msg_count FILE for list %s', $listname);
            next;
        }
        while (<COUNT>) {
            if (/^(\w+)\s+(\d+)/) {
                my ($a, $b) = ($1, $2);
                $list_traffic->{$a} = $b;
            }
        }
        close(COUNT);

        #for each bouncing user
        for (
            my $user_ref = $list->get_first_bouncing_list_member();
            $user_ref;
            $user_ref = $list->get_next_bouncing_list_member()
            ) {
            my $score = get_score($user_ref, $list_traffic) || 0;

            # Copying score into database.
            unless (
                $list->update_list_member(
                    $user_ref->{'email'}, bounce_score => $score
                )
                ) {
                $log->syslog('err', 'Error while updating DB for user %s',
                    $user_ref->{'email'});
                next;
            }
        }
    }
    return 1;
}

sub none {

    1;
}

# Routine for automatic bouncing users management
#
# This sub apply a treatment foreach category of bouncing-users
#
# The relation between possible actions and correponding subroutines
# is indicated by the following hash (%actions).
# It's possible to add actions by completing this hash and the one in list
# config (file List.pm, in sections "bouncers_levelX"). Then you must write
# the code for your action:
# The action subroutines have two parameter :
# - the name of the current list
# - a reference on users email list:
# Look at the "remove_bouncers" sub in List.pm for an example
sub process_bouncers {
    my ($task, $context) = @_;
    $log->syslog('info', 'Processing automatic actions on bouncing users');

    ## possible actions
    my %actions = (
        'remove_bouncers' => \&Sympa::List::remove_bouncers,
        'notify_bouncers' => \&Sympa::List::notify_bouncers,
        'none'            => \&none
    );

    my $all_lists = Sympa::List::get_lists('*');
    foreach my $list (@{$all_lists || []}) {
        my $listname = $list->{'name'};

        my @bouncers;
        # @bouncers = (
        #     ['email1', 'email2', 'email3',....,],    There is one line
        #     ['email1', 'email2', 'email3',....,],    foreach bounce
        #     ['email1', 'email2', 'email3',....,],    level.
        # );

        my $max_level;
        for (
            my $level = 1;
            defined($list->{'admin'}{'bouncers_level' . $level});
            $level++
            ) {
            $max_level = $level;
        }

        ##  first, bouncing email are sorted in @bouncer
        for (
            my $user_ref = $list->get_first_bouncing_list_member();
            $user_ref;
            $user_ref = $list->get_next_bouncing_list_member()
            ) {
            # Skip included users (cannot be removed)
            next if $user_ref->{'included'};

            for (my $level = $max_level; ($level >= 1); $level--) {

                if ($user_ref->{'bounce_score'} >=
                    $list->{'admin'}{'bouncers_level' . $level}{'rate'}) {
                    push(@{$bouncers[$level]}, $user_ref->{'email'});
                    $level = ($level - $max_level);
                }
            }
        }

        ## then, calling action foreach level
        for (my $level = $max_level; ($level >= 1); $level--) {
            my $action =
                $list->{'admin'}{'bouncers_level' . $level}{'action'};
            my $notification =
                $list->{'admin'}{'bouncers_level' . $level}{'notification'};
            my $robot_id = $list->{'domain'};

            if (@{$bouncers[$level] || []}) {
                ## calling action subroutine with (list,email list) in
                ## parameter
                unless ($actions{$action}->($list, $bouncers[$level])) {
                    $log->syslog(
                        'err',
                        'Error while calling action sub for bouncing users in list %s',
                        $listname
                    );
                    return undef;
                }

                # Notify owner or listmaster with list, action, email list.
                my $param = {
                    #'listname'  => $listname, # No longer used (<=6.1)
                    'action'    => $action,
                    'user_list' => \@{$bouncers[$level]},
                    'total'     => scalar(@{$bouncers[$level]}),
                };
                if ($notification eq 'owner') {
                    $list->send_notify_to_owner('automatic_bounce_management',
                        $param);
                } elsif ($notification eq 'listmaster') {
                    Sympa::send_notfy_to_listmaster($list,
                        'automatic_bounce_management', $param);
                }
            }
        }
    }
    return 1;
}

sub get_score {

    my $user_ref     = shift;
    my $list_traffic = shift;

    $log->syslog('debug', '(%s)', $user_ref->{'email'});

    my $min_period    = $Conf::Conf{'minimum_bouncing_period'};
    my $min_msg_count = $Conf::Conf{'minimum_bouncing_count'};

    # Analizing bounce_subscriber_field and keep useful infos for notation
    $user_ref->{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/;

    my $BO_period    = int($1 / 86400) - $Conf::Conf{'bounce_delay'};
    my $EO_period    = int($2 / 86400) - $Conf::Conf{'bounce_delay'};
    my $bounce_count = $3;
    my $bounce_type  = $4;

    my $msg_count = 0;
    my $min_day   = $EO_period;

    unless ($bounce_count >= $min_msg_count) {
        #not enough messages distributed to keep score
        $log->syslog('debug', 'Not enough messages for evaluation of user %s',
            $user_ref->{'email'});
        return undef;
    }

    unless (($EO_period - $BO_period) >= $min_period) {
        #too short bounce period to keep score
        $log->syslog('debug', 'Too short period for evaluate %s',
            $user_ref->{'email'});
        return undef;
    }

    # calculate number of messages distributed in list while user was bouncing
    foreach my $date (sort { $b <=> $a } keys(%$list_traffic)) {
        if (($date >= $BO_period) && ($date <= $EO_period)) {
            $min_day = $date;
            $msg_count += $list_traffic->{$date};
        }
    }

    # Adjust bounce_count when msg_count file is too recent, compared to the
    # bouncing period
    my $tmp_bounce_count = $bounce_count;
    unless ($EO_period == $BO_period) {
        my $ratio = (($EO_period - $min_day) / ($EO_period - $BO_period));
        $tmp_bounce_count *= $ratio;
    }

    ## Regularity rate tells how much user has bounced compared to list
    ## traffic
    $msg_count ||= 1;    ## Prevents "Illegal division by zero" error
    my $regularity_rate = $tmp_bounce_count / $msg_count;

    ## type rate depends on bounce type (5 = permanent ; 4 =tewmporary)
    my $type_rate = 1;
    $bounce_type =~ /(\d)\.(\d)\.(\d)/;
    if ($1 == 4) {       # if its a temporary Error: score = score/2
        $type_rate = .5;
    }

    my $note = $bounce_count * $regularity_rate * $type_rate;

    ## Note should be an integer
    $note = int($note + 0.5);

#    $note = 100 if ($note > 100); # shift between message ditrib & bounces =>
#    note > 100

    return $note;
}

### MISCELLANEOUS SUBROUTINES ###

## when we catch signal, just change the value of the loop variable.
sub sigterm {
    my ($sig) = @_;
    $log->syslog('notice',
        'Signal %s received, still processing current task', $sig);
    $end = 1;
}

## sort task name by their epoch date
sub epoch_sort {
    $a =~ /(\d+)\..+/;
    my $date1 = $1;
    $b =~ /(\d+)\..+/;
    my $date2 = $1;

    $date1 <=> $date2;
}

## change the label of a task file
sub change_label {
    my $task_file = $_[0];
    my $new_label = $_[1];

    my $new_task_file = $task_file;
    $new_task_file =~ s/(.+\.)(\w*)(\.\w+\.\w+$)/$1$new_label$3/;

    if (rename($task_file, $new_task_file)) {
        $log->syslog('notice', '%s renamed in %s', $task_file,
            $new_task_file);
    } else {
        $log->syslog('err', 'Error; can\'t rename %s in %s',
            $task_file, $new_task_file);
    }
}

## send a error message to list-master, log it, and change the label task into
## 'ERROR'
sub error {
    my $task_file = $_[0];
    my $message   = $_[1];

    my @param;
    $param[0] =
        "An error has occurred during the execution of the task $task_file :
                 $message";
    $log->syslog('err', '%s', $message);
    change_label($task_file, 'ERROR') unless $task_file eq '';
    #FIXME: Coresponding mail template would be added.
    Sympa::send_notify_to_listmaster('*', 'error_in_task', \@param);
}

sub sync_include {
    my ($task, $context) = @_;

    $log->syslog('debug2', '(%s)', $task->{'id'});

    my $list = $task->{'list_object'};

    $list->sync_include();
    $list->sync_include_admin()
        if (
        (   defined $list->{'admin'}{'editor_include'}
            && $#{$list->{'admin'}{'editor_include'}} > -1
        )
        || (defined $list->{'admin'}{'owner_include'}
            && $#{$list->{'admin'}{'owner_include'}} > -1)
        );

    if (!$list->has_include_data_sources()
        && (!$list->{'last_sync'}
            || ($list->{'last_sync'} > (stat("$list->{'dir'}/config"))[9]))
        ) {
        $log->syslog('debug', 'List %s no more require sync_include task',
            $list->{'name'});
        return -1;
    }
}

__END__

=encoding utf-8

=head1 NAME

task_manager, task_manager.pl - Daemon to Process Periodical Sympa Tasks

=head1 SYNOPSIS

S<B<task_manager.pl> [ B<--foreground> ] [ B<--debug> ]>

=head1 DESCRIPTION

XXX @todo doc

=head1 OPTIONS

=over 4

=item B<-d>, B<--debug>

Sets the debug mode

=item B<-f>, B<--config=>I<file>

Force task_manager to use an alternative configuration file instead
of F</var/sympa/etc/sympa.conf>.

=item B<-F>, B<--foreground>

Prevents the script from being daemonized

=item B<-h>, B<--help>

Prints this help message.

=item B<--log_level=>I<level>

Set log level.

=back

=head1 FILES

F</var/spool/sympa/task/> directory for task spool.

F</var/run/sympa/task_manager.pid> this file contains the process ID
of F<task_manager.pl>.

=head1 MORE DOCUMENTATION

The full documentation in HTML and PDF formats can be
found in L<http://www.sympa.org/manual/>.

The mailing lists (with web archives) can be accessed at
L<http://listes.renater.fr/sympa/lists/informatique/sympa>.

=head1 BUGS

Report bugs to Sympa bug tracker.
See L<http://www.sympa.org/tracking>.

=head1 SEE ALSO

L<sympa_msg(8)>, L<wwsympa(8)>

=cut
