# SPDX-License-Identifier: GPL-2.0-or-later

package Amavis::AV;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
}
use subs @EXPORT_OK;
use vars @EXPORT;

use POSIX qw(WIFEXITED WIFSIGNALED WIFSTOPPED
             WEXITSTATUS WTERMSIG WSTOPSIG);
use Errno qw(EPIPE ENOTCONN ENOENT EACCES EINTR EAGAIN ECONNRESET);
use Time::HiRes ();

use Amavis::Conf qw(:platform :confvars c cr ca);
use Amavis::In::Message;
use Amavis::IO::RW;
use Amavis::Lookup qw(lookup lookup2);
use Amavis::Out qw(mail_dispatch);
use Amavis::ProcControl qw(exit_status_str proc_status_ok
                           run_command run_as_subprocess
                           collect_results collect_results_structured);
use Amavis::rfc2821_2822_Tools qw(one_response_for_all);
use Amavis::Timing qw(section_time);
use Amavis::Util qw(ll untaint min max minmax unique_list do_log
                    add_entropy proto_decode rmdir_recursively
                    prolong_timer get_deadline generate_mail_id);

use vars qw(%st_socket_created %st_sock); # keep persistent state (per-socket)

sub clamav_module_init($) {
  my $av_name = $_[0];
  # each child should reinitialize clamav module to reload databases
  my $clamav_version = Mail::ClamAV->VERSION;
  my $dbdir = Mail::ClamAV::retdbdir();
  my $clamav_obj = Mail::ClamAV->new($dbdir);
  ref $clamav_obj
    or die "$av_name: Can't load db from $dbdir: $Mail::ClamAV::Error";
  $clamav_obj->buildtrie;
  $clamav_obj->maxreclevel($MAXLEVELS)  if $MAXLEVELS > 0;
  $clamav_obj->maxfiles($MAXFILES)      if $MAXFILES  > 0;
  $clamav_obj->maxfilesize($MAX_EXPANSION_QUOTA || 50*1024*1024);
  if ($clamav_version >= 0.12) {
    $clamav_obj->maxratio($MAX_EXPANSION_FACTOR);
#   $clamav_obj->archivememlim(0);  # limit memory usage for bzip2 (0/1)
  }
  do_log(3,"clamav_module_init: %s init", $av_name);
  section_time('clamav_module_init');
  ($clamav_obj,$clamav_version);
}

# called from sub ask_clamav or ask_daemon, should not run as a subprocess
#
use vars qw($clamav_obj $clamav_version);
sub clamav_module_internal_pre($) {
  my $av_name = $_[0];
  if (!defined $clamav_obj) {
    ($clamav_obj,$clamav_version) = clamav_module_init($av_name);  # first time
  } elsif ($clamav_obj->statchkdir) {     # db reload needed?
    do_log(2, "%s: reloading virus database", $av_name);
    ($clamav_obj,$clamav_version) = clamav_module_init($av_name);
  }
}

# called from sub ask_clamav or ask_daemon, may be called directly
# or in a subprocess
#
sub clamav_module_internal($@) {
  my($query, $bare_fnames,$names_to_parts,$tempdir, $av_name) = @_;
  $query = join(' ',@$query)  if ref $query;
  my $fname = "$tempdir/parts/$query";   # file to be checked
  my $part = $names_to_parts->{$query};  # get corresponding parts object
  my $options = 0;  # bitfield of options to Mail::ClamAV::scan
  my($opt_archive,$opt_mail);
  if ($clamav_version < 0.12) {
    $opt_archive = &Mail::ClamAV::CL_ARCHIVE;
    $opt_mail    = &Mail::ClamAV::CL_MAIL;
  } else {         # >= 0.12, reflects renamed flags in libclamav 0.80
    $opt_archive = &Mail::ClamAV::CL_SCAN_ARCHIVE;
    $opt_mail    = &Mail::ClamAV::CL_SCAN_MAIL;
  }
  # see clamav.h for standard options enabled by CL_SCAN_STDOPT
  $options |= &Mail::ClamAV::CL_SCAN_STDOPT  if $clamav_version >= 0.13;
  $options |= $opt_archive;  # turn on ARCHIVE
  $options &= ~$opt_mail;    # turn off MAIL
  my $type_decl = $part->type_declared;
  if (ref $part &&
      ($part->type_short eq 'MAIL' ||
       defined $type_decl && $type_decl=~m{^message/(?:rfc822|global)\z}si)) {
    do_log(2, "%s: $query - enabling option CL_MAIL", $av_name);
    $options |= $opt_mail;   # turn on MAIL
  }
  my $ret = $clamav_obj->scan(untaint($fname), $options);
  my($output,$status);
  if    ($ret->virus) { $status = 1; $output = "INFECTED: $ret" }
  elsif ($ret->clean) { $status = 0; $output = "CLEAN" }
  else { $status = 2; $output = $ret->error.", errno=".$ret->errno }
  ($status,$output);  # return synthesised status and a result string
}

# subroutine available for calling from @av_scanners list entries;
# it has the same args and returns as run_av() below
#
sub ask_clamav {
  my($bare_fnames,$names_to_parts,$tempdir, $av_name) = @_;
  clamav_module_internal_pre($av_name);  # must not run as a subprocess
# my(@results) = ask_av(\&clamav_module_internal, @_);  # invoke directly
  my($proc_fh,$pid) = run_as_subprocess(\&ask_av, \&clamav_module_internal,@_);
  my($results_ref,$child_stat) =
    collect_results_structured($proc_fh,$pid,$av_name,200*1024);
  !$results_ref ? () : @$results_ref;
}

my $savi_obj;
sub sophos_savi_init {
  my($av_name, $command) = @_;
  my(@savi_bool_options) = qw(
         GrpArchiveUnpack GrpSelfExtract GrpExecutable GrpInternet GrpMSOffice
         GrpMisc !GrpDisinfect !GrpClean EnableAutoStop FullSweep FullPdf Xml
  );
  $savi_obj = SAVI->new;
  ref $savi_obj or die "$av_name: Can't create SAVI object, err=$savi_obj";
  my $status = $savi_obj->load_data;
  !defined($status) or die "$av_name: Failed to load SAVI virus data " .
                           $savi_obj->error_string($status) . " ($status)";
  my $version = $savi_obj->version;
  ref $version or die "$av_name: Can't get SAVI version, err=$version";
  do_log(2,"%s init: Version %s (engine %d.%d) recognizing %d viruses",
           $av_name, $version->string, $version->major, $version->minor,
           $version->count);
  my $error;
  if ($MAXLEVELS > 0) {
    $error = $savi_obj->set('MaxRecursionDepth', $MAXLEVELS);
    !defined $error
      or die "$av_name: error setting MaxRecursionDepth: err=$error";
  }
  $error = $savi_obj->set('NamespaceSupport', 3);  # new with Sophos 3.67
  !defined $error
    or do_log(-1,"%s: error setting NamespaceSupport: err=%s",$av_name,$error);
  for (@savi_bool_options) {
    my $value = /^!/ ? 0 : 1;  s/^!+//;
    $error = $savi_obj->set($_, $value);
    !defined $error or die "$av_name: Error setting $_: err=$error";
  }
  section_time('sophos_savi_init');
  1;
}

sub sophos_savi_stale {
  defined $savi_obj && $savi_obj->stale;
}

# run by a master(!) process, invoked from a hook run_n_children_hook
#
sub sophos_savi_reload {
  if (defined $savi_obj) {
    do_log(3,"sophos_savi_reload: about to reload SAVI data");
    eval {
      my $status = $savi_obj->load_data;
      do_log(-1,"sophos_savi_reload: failed to load SAVI virus data %s (%s)",
                 $savi_obj->error_string($status), $status) if defined $status;
      1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      do_log(-1,"sophos_savi_reload failed: %s", $eval_stat);
    };
    my $version = $savi_obj->version;
    if (!ref($version)) {
      do_log(-1,"sophos_savi_reload: Can't get SAVI version: %s", $version);
    } else {
      do_log(2,"Updated SAVI data: Version %s (engine %d.%d) ".
               "recognizing %d viruses", $version->string,
               $version->major, $version->minor, $version->count);
    }
  }
}

# to be called from sub sophos_savi
#
sub sophos_savi_internal {
  my($query,
     $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args) = @_;
  $query = join(' ',@$query)  if ref $query;
  my $fname = "$tempdir/parts/$query";  # file to be checked
  if (!c('bypass_decode_parts')) {
    my $part = $names_to_parts->{$query};  # get corresponding parts object
    my $mime_option_value = 0;
    my $type_decl = $part->type_declared;
    if (ref $part &&
        ($part->type_short eq 'MAIL' ||
         defined $type_decl && $type_decl=~m{^message/(?:rfc822|global)\z}si)){
      do_log(2, "%s: %s - enabling option Mime", $av_name, $query);
      $mime_option_value = 1;
    }
    my $error = $savi_obj->set('Mime', $mime_option_value);
    !defined $error or die sprintf("%s: Error %s option Mime: err=%s",
                $av_name, $mime_option_value ? 'setting' : 'clearing', $error);
  }
  my($output,$status); $!=0; my $result = $savi_obj->scan($fname);
  if (!ref($result)) {  # error
    my $msg = "error scanning file $fname, " .
              $savi_obj->error_string($result) . " ($result)";  # ignore $! ?
    if ( !grep($result == $_, (514,527,530,538,549)) ) {
      $status = 2; $output = "ERROR $query: $msg";
    } else { # don't panic on non-fatal (encrypted, corrupted, partial)
      $status = 0; $output = "CLEAN $query: $msg";
    }
    do_log(5,"%s: %s", $av_name,$output);
  } elsif ($result->infected) {
    $status = 1; $output = join(", ", $result->viruses) . " FOUND";
  } else {
    $status = 0; $output = "CLEAN $query";
  }
  ($status,$output);  # return synthesised status and a result string
}

# implements client side of the Sophos SSSP protocol
#
sub sophos_sssp_internal {
  my($query,
     $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args) = @_;
  my($query_template, $socket_specs) = !$args ? () : @$args;

  # short timeout for connect and sending a request
  prolong_timer('sophos_sssp_connect', undef, undef, 10);
  my($remaining_time, $deadline) = get_deadline('sophos_sssp_internal');
  # section_time('sssp-pre');

  my $sssp_handle =
    Amavis::IO::RW->new($socket_specs, Eol => "\015\012", Timeout => 10);
  defined $sssp_handle or die "Can't connect to savdid";
  # section_time('sssp-conn');

  my $ln; local($1);
  $ln = $sssp_handle->get_response_line;  # greeting
  defined $ln && $ln ne ''  or die "sssp no greeting";
  do_log(5,"sssp greeting %s", $ln);
  $ln =~ m{^OK\s+SSSP/(\d+.*)\015\012\z}s  or die "sssp bad greeting '$ln'";
  # section_time('sssp-greet');

# # Use the SSSP OPTIONS request only if necessary, it is cheaper to have the
# # options set in the configuration file. If a client has needs different
# # from other clients, create another channel tailored for that client.
# #
# $sssp_handle->print("SSSP/1.0 OPTIONS\015\012".
#                     "savists:zipdecompression 1\015\012".
#                     "output: brief\015\012\015\012")
#   or die "Error writing to sssp socket";
# $sssp_handle->flush or die "Error flushing sssp socket";
# $ln = $sssp_handle->get_response_line;
# defined $ln && $ln ne ''  or die "sssp no response to OPTIONS";
# do_log(5,"sssp response to OPTIONS: %s", $ln);
# $ln =~ /^ACC\s+(\S*)/  or die "sssp OPTIONS request not accepted";
# while (defined($ln = $sssp_handle->get_response_line)) {
#   last if $ln eq "\015\012";
#   do_log(5,"sssp result of OPTIONS: %s", $ln);
# }
# # section_time('sssp-opts');

  my $output = '';
  # normal timeout for reading a response
  prolong_timer('sophos_sssp_scan');
  $sssp_handle->timeout(max(3, $deadline - Time::HiRes::time));
  for my $fname (!ref($query) ? $query : @$query) {
    my $fname_enc = $fname;
    $fname_enc =~ s/([%\000-\040\177\377])/sprintf("%%%02X",ord($1))/gse;
    $sssp_handle->print("SSSP/1.0 SCANDIRR $fname_enc\015\012")
      or die "Error writing to sssp socket";
    $sssp_handle->flush or die "Error flushing sssp socket";
    $ln = $sssp_handle->get_response_line;
    defined $ln && $ln ne ''  or die "sssp no response to SCANDIRR";
    do_log(5,"sssp response to SCANDIRR: %s", $ln);
    # section_time('sssp-scan-ack');
    $ln =~ /^ACC\s+(\S*)/  or die "sssp SCANDIRR request not accepted";
    while (defined($ln = $sssp_handle->get_response_line)) {
      last if $ln eq "\015\012";
      do_log(3,"sssp result: %s", $ln);
      $output .= $ln  if length($output) < 10000;
    }
  }
  $output = proto_decode($output);
  # section_time('sssp-scan-result');

  $sssp_handle->print("BYE\015\012") or die "Error writing to sssp socket";
  $sssp_handle->flush or die "Error flushing sssp socket";
  $sssp_handle->timeout(max(3, $deadline - Time::HiRes::time));
  while (defined($ln = $sssp_handle->get_response_line)) {
    do_log(5,"sssp response to BYE: %s", $ln);
    last if $ln eq "\015\012" || $ln =~ /^BYE/;
  }
  # section_time('sssp-bye');
  $sssp_handle->close  or do_log(-1, "sssp - error closing session: $!");
  # section_time('sssp-close');
  (0,$output);  # return synthesised status and a result string
}

# implements client side of the AVIRA SAVAPI3 protocol
#
sub avira_savapi_internal {
  my($query,
     $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args) = @_;
  my($query_template, $socket_specs, $product_id) = !$args ? () : @$args;

  # short timeout for connect and sending a request
  prolong_timer('avira_savapi_connect', undef, undef, 10);
  my($remaining_time, $deadline) = get_deadline('avira_savapi_internal');
  # section_time('savapi-pre');

  my $savapi_handle =
    Amavis::IO::RW->new($socket_specs, Eol => "\012", Timeout => 10);
  defined $savapi_handle or die "Can't connect to savapi daemon";
  # section_time('savapi-conn');

  my $ln; local($1);
  $ln = $savapi_handle->get_response_line;  # greeting
  defined $ln && $ln ne ''  or die "savapi no greeting";
  do_log(5,"savapi greeting %s", $ln);
  $ln =~ m{^100 SAVAPI:(\d+.*)\012\z}s  or die "savapi bad greeting '$ln'";
  # section_time('savapi-greet');

  $remaining_time = int(max(3, $deadline - Time::HiRes::time + 0.5));
  for my $cmd ("SET PRODUCT $product_id",
               "SET SCAN_TIMEOUT $remaining_time",
               "SET CWD $tempdir/parts",
              ) {
    # consider: "SET MAILBOX_SCAN 1", "SET ARCHIVE_SCAN 1", "SET HEUR_LEVEL 2"
    $savapi_handle->print($cmd."\012") or die "Error writing '$cmd' to socket";
    $savapi_handle->flush or die "Error flushing socket";
    $ln = $savapi_handle->get_response_line;
    defined $ln && $ln ne ''  or die "savapi: no response to $cmd";
    do_log(5,"savapi response to '%s': %s", $cmd,$ln);
    $ln =~ /^100/  or die "savapi: $cmd request not accepted: $ln";
  }
  # section_time('savapi-settings');

  # set a normal timeout for reading a response
  prolong_timer('avira_savapi_scan');
  $savapi_handle->timeout(max(3, $deadline - Time::HiRes::time));
  my $keep_one_success; my $output = '';
  for my $fname (!ref($query) ? $query : @$query) {
    my $cmd = "SCAN $fname";  # files only, no directories
    $savapi_handle->print($cmd."\012") or die "Error writing '$cmd' to socket";
    $savapi_handle->flush or die "Error flushing socket";
    while (defined($ln = $savapi_handle->get_response_line)) {
      do_log(5,"savapi response to '%s': %s", $cmd,$ln);
      if ($ln =~ /^200/) {  # clean
        $keep_one_success = $ln  if !defined $keep_one_success;
      } else {
        $output .= $ln  if length($output) < 10000;  # sanity limit
      }
      last if $ln =~ /^([0125-9]\d\d|300|319).*\012/;  # terminal status
    # last if $ln =~ !/^(310|420|421|422|430).*\012/;  # nonterminal status
    }
  }
  $output = $keep_one_success  if $output eq '' && defined $keep_one_success;
  do_log(5,"savapi result: %s", $output);
  # section_time('savapi-scan-result');

  $savapi_handle->print("QUIT\012")
    or do_log(-1, "savapi - error writing QUIT to socket");
  $savapi_handle->flush
    or do_log(-1, "savapi - error flushing socket after QUIT");
  $savapi_handle->close
    or do_log(-1, "savapi - error closing session: $!");
  # section_time('savapi-close');
  (0,$output);  # return synthesised status and a result string
}

# implements client side of the ClamAV clamd protocol
#
sub clamav_clamd_internal {
  my($query,
     $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args) = @_;
  my($query_template, $socket_specs, $product_id) = !$args ? () : @$args;

  # short timeout for connect
  prolong_timer('clamav_connect', undef, undef, 10);
  my($remaining_time, $deadline) = get_deadline('clamav_internal');
  my $clamav_handle =
    Amavis::IO::RW->new($socket_specs, Eol => "\000", Timeout => 10);
  $clamav_handle or die "Can't connect to a clamd daemon";

  # set a normal timeout
  prolong_timer('clamav_scan');
  $clamav_handle->timeout(max(3, $deadline - Time::HiRes::time));
  $clamav_handle->print("zIDSESSION\0")
    or die "Error writing 'zIDSESSION' to a clamd socket: $!";

  my(@requests, @requests_filename, @requests_timestamp, $end_sent);
  my($req_id, $requests_pending) = (0,0);
  my $requests_remaining = !ref $query ? 1 : scalar @$query;
  my($keep_one_success, $aborted_id, $found_infected);
  my $output = '';
  while ($requests_remaining > 0 || $requests_pending > 0) {
    my $throttling = $requests_pending >= 8;
    if ($throttling) {
      # wait first for some of the pending results before sending new requests
      $clamav_handle->flush or die "Error flushing socket: $!";
      do_log(5,'clamav: throttling: %d pending, %d remaining',
               $requests_pending, $requests_remaining);
    } elsif ($requests_remaining > 0) {
      my $fname = !ref $query ? $query : $query->[$req_id];
      $req_id++;
      $requests[$req_id] = 'INITIATING';
      $requests_filename[$req_id] = $fname;
      ll(5) && do_log(5,'clamav: sending contents of %s, req_id %d',
                      $fname, $req_id);
      $clamav_handle->print("zINSTREAM\0")
        or die "Error writing 'zINSTREAM' to a clamd socket: $!";
      $requests[$req_id] = 'OPEN';
      my $fh = IO::File->new;
      $fh->open($fname,'<') or die "Can't open file $fname: $!";
      binmode($fh,':bytes') or die "Can't cancel :utf8 mode: $!";
      eval {
        my($nbytes,$buff); $buff = pack('N',0);
        while (($nbytes=$fh->read($buff, 32768-4, 4)) > 0) {
          $requests[$req_id] = 'SENDING';
          substr($buff,0,4) = pack('N',$nbytes);  # 32 bits len -> 4 bytes
          $clamav_handle->print($buff)
            or die "Error writing $nbytes bytes to a clamd socket: $!";
        }
        defined $nbytes or die "Error reading from $fname: $!";
        my $eod = pack('N',0);  # length zero indicates end of data
        if ($requests_remaining <= 0) { $eod .= "zEND\0"; $end_sent = 1 }
        $clamav_handle->print($eod)
          or die "Error writing end-of-data to a clamd socket: $!";
        $clamav_handle->flush or die "Error flushing clamd socket: $!";
        $requests[$req_id] = 'SENT';
        1;
      } or do {
        my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        $requests[$req_id] = 'ABORTED: '.$eval_stat;
        $aborted_id = $req_id;  # also boolean true, request IDs start with 1
        do_log(-1,'clamav: while feeding req_id %d: %s', $req_id, $eval_stat);
        my $disc_len = $clamav_handle->discard_pending_output;
        do_log(2,'clamav: discarding %d bytes', $disc_len)  if $disc_len;
      };
      $requests_timestamp[$req_id] = Time::HiRes::time;
      $requests_remaining--; $requests_pending++;
      $fh->close or die "Error closing file $fname: $!";
      do_log(5,'clamav: finished sending %s, req_id %d', $fname, $req_id);
    }
    while ( ($requests_pending > 0 && !$aborted_id) ||
            $clamav_handle->response_line_available ) {
      my $ln = $clamav_handle->get_response_line;
      last if !defined $ln;
      my $rx_time = Time::HiRes::time;
      do_log(5,'clamav: got response %s', $ln);

      my($id, $id_n, $resp); local($1,$2);
      if ($ln =~ /^(\d+):\s*(.*?)\000\z/s) {
        ($id,$resp) = ($1,$2); $id_n = 0+$id;
      } elsif ($ln =~ / ERROR\000\z/) {
        if ($aborted_id) {
          $id = $aborted_id; $id_n = 0+$id;
          do_log(-1,'clamav: (possibly id=%d) error response: %s', $id,$ln);
        } else {
          do_log(-1,'clamav: error response: %s', $ln);
        }
      } else {
        do_log(-1,'clamav: unparseable response %s', $ln);
        next;
      }
      if (!defined $id) {
        # failure already reported
      } elsif (!defined $requests[$id_n]) {
        do_log(-1,'clamav: bogus id %s in response ignored: %s', $id,$ln);
      } elsif ($requests[$id_n] eq 'DONE') {
        do_log(-1,'clamav: duplicate result for id %s: %s', $id,$ln);
      } else {
        ll(5) && do_log(5,'clamav: request id %s on %s took %.1f ms',
                          $id, $requests_filename[$id_n],
                          1000 * ($rx_time - $requests_timestamp[$id_n]));
        if ($requests[$id_n] ne 'SENT') {
          do_log(2,'clamav: result based on incomplete data, state %s: %s',
                   $requests[$id_n], $ln);
        }
        $ln =~ s/\000\z/\n/s;
        $ln =~ s/^\Q$id\E:\s*stream:\s*/$requests_filename[$id_n]: /s;
        if (defined $resp && $resp =~ /\bOK\z/) {  # clean
          $keep_one_success = $ln  if !defined $keep_one_success;
        } else {
          $output .= $ln  if length($output) < 10000;  # sanity limit
        }
        $requests[$id_n] = 'DONE';
        $requests_pending--  if $requests_pending > 0;
        undef $requests_filename[$id_n];
        undef $requests_timestamp[$id_n];
        if ($resp =~ /\bFOUND\z/) {
          $found_infected = 1;
          if ($requests_remaining > 0 && c('first_infected_stops_scan')) {
            do_log(2,'clamav: first infected stops scan');
            $requests_remaining = 0;
          }
        }
      }
    }
    if ($aborted_id) {
      do_log(-1,'clamav: aborting: %d pending, %d remaining',
                $requests_pending, $requests_remaining);
      $clamav_handle->close
        or do_log(5,'clamav: error closing session: %s', $!);
      undef $clamav_handle;
      if ($found_infected) {
        # just normally return an infection report,
        # even though not all content has been scanned
        do_log(5,'clamav: result: %s', $output);
        return (0,$output);  # return synthesised status and a result string
      } else {
        die 'clamav: '.$requests[$aborted_id];
      }
    }
  }
  $output = $keep_one_success  if $output eq '' && defined $keep_one_success;
  do_log(5,'clamav: result: %s', $output);
  if ($clamav_handle) {
    if (!$end_sent) {
      $clamav_handle->print("zEND\0")
        or do_log(-1,"clamav: error writing 'zEND' to a clamd socket: %s", $!);
    }
    $clamav_handle->close
      or do_log(-1,'clamav: error closing session: %s', $!);
  }
  (0,$output);  # return synthesised status and a result string
}

sub av_smtp_client($$$$) {
  my($msginfo,$av_name,$av_test_method,$av_test_recip) = @_;
  $av_test_recip = 'dummy@localhost'  if !defined $av_test_recip;
  my $test_msg = Amavis::In::Message->new;
  $test_msg->rx_time($msginfo->rx_time);      # copy the reception time
  $test_msg->log_id($msginfo->log_id);        # use the same log_id
  $test_msg->partition_tag($msginfo->partition_tag);  # same partition_tag
  $test_msg->parent_mail_id($msginfo->mail_id);
  $test_msg->mail_id(scalar generate_mail_id());
  $test_msg->conn_obj($msginfo->conn_obj);
  $test_msg->mail_id($msginfo->mail_id);      # use the same mail_id
  $test_msg->body_type($msginfo->body_type);  # use the same BODY= type
  $test_msg->header_8bit($msginfo->header_8bit);
  $test_msg->body_8bit($msginfo->body_8bit);
  $test_msg->body_digest($msginfo->body_digest);  # copy original digest
  $test_msg->dsn_ret($msginfo->dsn_ret);
  $test_msg->dsn_envid($msginfo->dsn_envid);
  $test_msg->smtputf8($msginfo->smtputf8);
  $test_msg->sender($msginfo->sender);        # original sender
  $test_msg->sender_smtp($msginfo->sender_smtp);
  $test_msg->auth_submitter($msginfo->sender_smtp);
  $test_msg->auth_user(c('amavis_auth_user'));
  $test_msg->auth_pass(c('amavis_auth_pass'));
  $test_msg->recips([$av_test_recip]);        # made-up recipient
  $_->delivery_method($av_test_method)  for @{$test_msg->per_recip_data};
  $test_msg->originating(0);                  # disables DKIM signing
  $test_msg->mail_text($msginfo->mail_text);  # the original mail contents
  $test_msg->mail_text_str($msginfo->mail_text_str);
  $test_msg->body_start_pos($msginfo->body_start_pos);
  $test_msg->skip_bytes($msginfo->skip_bytes);
  # NOTE: $initial_submission argument is typically treated as a boolean
  # but here a value of 2 is supplied to allow a forwarding method to
  # distinguish it from ordinary submissions
  mail_dispatch($test_msg, 'AV', 0);
  my($smtp_resp, $exit_code, $dsn_needed) =
    one_response_for_all($test_msg, 0);  # check status
  do_log(2, "av_smtp_client %s: %s, %s", $av_name,$av_test_method,$smtp_resp);
  (0, $smtp_resp);
}

# same args and returns as run_av() below,
# but prepended by a $query, which is a string to be sent to the daemon.
# Handles UNIX, INET and INET6 domain sockets.
# More than one socket may be specified for redundancy, they will be tried
# one after the other until one succeeds.
#
sub ask_daemon_internal {
  my($query,  # expanded query template, often a command and a file or dir name
     $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args,
     $sts_clean,$sts_infected,$how_to_get_names,  # regexps
  ) = @_;
  my($query_template_orig,$socket_specs) = @$args;
  my $output = '';
  $socket_specs = [ $socket_specs ]  if !ref($socket_specs);
  my($remaining_time, $deadline) =
    get_deadline('ask_daemon_internal_connect_pre');
  my $max_retries = 2 * @$socket_specs;  my $retries = 0;
  # Sophie, Trophie and fpscand can accept multiple requests per session
  # and return a single line response each time
  my $multisession = $av_name =~ /\b(Sophie|Trophie|fpscand)\b/i ? 1 : 0;
  for (;;) {  # gracefully handle cases when av process times out or restarts
    # short timeout for connect and sending a request
    prolong_timer('ask_daemon_internal_connect', undef, undef, 10);
    @$socket_specs  or die "panic, no sockets specified!?";  # sanity
    # try the first one in the current list
    my $socketname = $socket_specs->[0];
    my $sock = $st_sock{$socketname};
    my $eval_stat;
    eval {
      if (!$st_socket_created{$socketname}) {
        ll(3) && do_log(3, "%s: Connecting to socket %s %s%s",
                           $av_name, $daemon_chroot_dir, $socketname,
                           !$retries ? '' : ", retry #$retries" );
        $sock = Amavis::IO::RW->new($socketname, Timeout => 10);
        $st_sock{$socketname} = $sock;
        defined $sock or die "Can't connect to socket $socketname\n";
        $st_socket_created{$socketname} = 1;
      }
      $query = join(' ',@$query)  if ref $query;
      ll(3) && do_log(3,"%s: Sending %s to socket %s",
                        $av_name, $query, $socketname);
      $sock->print($query) or die "Error writing to socket $socketname\n";
      $sock->flush         or die "Error flushing socket $socketname\n";

      # normal timeout for reading a response
      prolong_timer('ask_daemon_internal_scan');
      $sock->timeout(max(3, $deadline - Time::HiRes::time));
      if ($multisession) {
        # depends on TCP segment boundaries, unreliable
        my $nread = $sock->read($output,16384);
        defined $nread  or die "Error reading from $socketname: $!\n";
        # and keep the socket open
      } else {  # single request/response per connection
        my $buff = '';
        for (;;) {
          my $nread = $sock->read($buff,16384);
          if (!defined($nread)) {
            die "Error reading from $socketname: $!\n";
          } elsif ($nread < 1) {
            last;   # sysread returns 0 at eof
          } else {  # successful read
            $output .= $buff  if length($output) < 100000;  # sanity
          }
        }
        $sock->close  or die "Error closing socket $socketname\n";
        $st_sock{$socketname} = $sock = undef;
        $st_socket_created{$socketname} = 0;
      }
      $output ne '' or die "Empty result from $socketname\n";
      1;
    } or do {
      $eval_stat = $@ ne '' ? $@ : "errno=$!";
    };
    prolong_timer('ask_daemon_internal');
    last  if !defined $eval_stat;  # mission accomplished

    # error handling (the most interesting error codes are EPIPE and ENOTCONN)
    chomp $eval_stat; my $err = "$!"; my $errn = 0+$!;

    # close socket through its DESTROY method, ignoring status
    $st_sock{$socketname} = $sock = undef;
    $st_socket_created{$socketname} = 0;

    if (Time::HiRes::time >= $deadline) {
      die "ask_daemon_internal: Exceeded allowed time";
    }
    ++$retries <= $max_retries
      or die "Too many retries to talk to $socketname ($eval_stat)";
    if ($retries <= 1 && $errn == EPIPE) {  # common, don't cause concern
      do_log(2,"%s broken pipe (don't worry), retrying (%d)",
               $av_name,$retries);
    } else {
      do_log( ($retries > 1 ? -1 : 1),
              "%s: %s, retrying (%d)", $av_name,$eval_stat,$retries);
      if ($retries % @$socket_specs == 0) {  # every time the list is exhausted
        my $dly = min(20, 1 + 5 * ($retries/@$socket_specs - 1));
        do_log(3,"%s: sleeping for %s s", $av_name,$dly);
        sleep($dly);   # slow down a possible runaway
      }
    }
    # leave good socket as the first entry in the list
    # so that it will be tried first when needed again
    if (@$socket_specs > 1) {
      push(@$socket_specs, shift @$socket_specs);  # circular shift left
    }
  }
  (0,$output);  # return synthesised status and a result string
}

# subroutine is available for calling from @av_scanners list entries;
# it has the same args and returns as run_av() below.
# Based on an implied protocol, or on an explicitly specified protocol name
# in the second element of array @$args, it determines a subroutine needed
# to implement the required protocol (defaulting to &ask_daemon_internal)
# and replaces $command in the argument list by this subroutine reference,
# then calls run_av with adjusted arguments.  So, its main purpose is to map
# a protocol name (a string) into an internal code reference.
#
sub ask_daemon {
  my($bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args,
     $sts_clean,$sts_infected,$how_to_get_names) = @_;
  my($av_method,$av_protocol); local($1);
  # determine a protocol name from the second element of array @$args
  $av_method = $args->[1]  if $args && @$args >= 2;
  $av_method = $av_method->[0]  if ref $av_method;
  $av_protocol = lc($1)  if defined $av_method &&
                            $av_method =~ /^([a-z][a-z0-9.+-]*):/si;
  my $code; my $run_spawned = 0;
  if (!defined $av_protocol) {
    # for compatibility with old style socket specification with
    # no protocol (scheme) field, equivalent to a former call to ask_av()
    #   Sophie, Trophie, ClamAV-clamd, OpenAntiVirus, AVG,
    #   F-Prot fpscand, F-Prot f-protd, DrWebD, avast, ESET NOD32SS
    $code = \&ask_daemon_internal;
  } elsif ($av_protocol =~ /^(simple|sophie|trophie)\z/) {
    # same as default, but with an explicit protocol prefix
    $code = \&ask_daemon_internal;
  } elsif ($av_protocol eq 'sssp') {  # Sophos SSSP
    $code = \&sophos_sssp_internal;
  } elsif ($av_protocol eq 'savapi') {  # Avira SAVAPI3
    $code = \&avira_savapi_internal;
  } elsif ($av_protocol eq 'clamd') {  # ClamAV clamd protocol
    $code = \&clamav_clamd_internal;
  } elsif ($av_protocol eq 'smtp' || $av_protocol eq 'lmtp') {
    $code = sub { av_smtp_client($Amavis::MSGINFO, $av_name,
                                 $av_method, $args->[2]) };
  } elsif ($av_protocol eq 'savi-perl') {  # using SAVI-Perl perl module
    if (@_ < 3+6) {  # supply default arguments for backward compatibility
      $args = ['*']; $sts_clean = [0]; $sts_infected = [1];
      $how_to_get_names = qr/^(.*) FOUND$/m;
    }
    $code = \&sophos_savi_internal;
  } elsif ($av_protocol eq 'clamav-perl') {  # using Mail::ClamAV perl module
    clamav_module_internal_pre($av_name);  # must not run as a subprocess
    $code = \&clamav_module_internal; $run_spawned = 1;
  }
  ll(5) && do_log(5, "ask_daemon: proto=%s, spawn=%s, (%s) %s",
                     !defined $av_protocol ? 'DFLT' : $av_protocol,
                     $run_spawned, $av_name, $av_method);
  ref $code or die "Unsupported AV protocol name: $av_method";
  $command = $code;
  # reassemble arguments, after possibly being modified
  my(@run_av_args) = ($bare_fnames,$names_to_parts,$tempdir,
          $av_name,$command,$args, $sts_clean,$sts_infected,$how_to_get_names);
  my(@results);
  if (!$run_spawned) {
    @results = run_av(@run_av_args);  # invoke directly
  } else {
    my($proc_fh,$pid) = run_as_subprocess(\&ask_av, @run_av_args);
    my($results_ref,$child_stat) =
      collect_results_structured($proc_fh,$pid,$av_name,200*1024);
    @results = @$results_ref  if $results_ref;
  }
  @results;  # ($scan_status,$output,$virusnames)
}

# for compatibility with pre-2.6.0 versions of amavisd-new and
# old @av_scanners entries;  use ask_daemon and/or run_av instead
sub ask_av(@) {
  my($code, @run_av_args) = @_;
  $run_av_args[4] = $code;  # replaces $command with a supplied $code
  run_av(@run_av_args);
}

# Call a virus scanner and parse its output.
# Returns a triplet, or dies in case of failure.
# The first element of the triplet has the following semantics:
# - true if virus found,
# - 0 if no viruses found,
# - undef if it did not complete its job;
# the second element is a string, the text as provided by the virus scanner;
# the third element is ref to a list of virus names found (if any).
#   (it is guaranteed the list will be nonempty if virus was found)
#
# If there is at least one glob character '*' present in a query template, the
# subroutine will traverse supplied files (@$bare_fnames) and call a supplied
# subroutine or program for each file to be scanned, summarizing the final
# av scan result. If there are no glob characters in a template, the result
# is a single call to a supplied subroutine or program, which will presumably
# traverse a directory by itself.
#
sub run_av(@) {
  my($bare_fnames,  # a ref to a list of filenames to scan (basenames)
     $names_to_parts, # ref to a hash that maps base file names to parts object
     $tempdir,      # temporary directory
      # n-tuple from an @av_scanners list entry starts here
     $av_name, $command, $args,
     $sts_clean,    # a ref to a list of status values, or a regexp
     $sts_infected, # a ref to a list of status values, or a regexp
     $how_to_get_names, # ref to sub, or a regexp to get list of virus names
     $pre_code, $post_code,  # routines to be invoked before and after av
  ) = @_;
  my($scan_status,@virusnames,$error_str); my $output = '';
  return (0,$output,\@virusnames)  if !defined($bare_fnames) || !@$bare_fnames;
  my($query_template, $socket_specs); my $av_protocol = '';
  if (!ref $args) {
    $query_template = $args;
  } else {
    ($query_template, $socket_specs) = @$args;
    $socket_specs = $socket_specs->[0]  if ref $socket_specs;
    if (defined $socket_specs) {
      local($1);
      $av_protocol = lc($1)  if $socket_specs =~ /^([a-z][a-z0-9.+-]*):/si;
    }
  }
  my $one_at_a_time = 0;
  $one_at_a_time = 1  if ref $command &&
                         $av_protocol !~ /^(?:sssp|savapi|clamd)\z/;
  my(@query_template) = $one_at_a_time ? $query_template  # treat it as one arg
                                    : split(' ',$query_template);  # shell-like
  my $bare_fnames_last = $#{$bare_fnames};
  do_log(5,"run_av (%s): query template(%s,%d): %s",
           $av_name,$one_at_a_time,$bare_fnames_last,$query_template);
  my($remaining_time, $deadline) = prolong_timer('run_av_pre');
  my $cwd = "$tempdir/parts";
  chdir($cwd) or die "Can't chdir to $cwd: $!";
  &$pre_code(@_)  if defined $pre_code;
  # a '{}' will be replaced by a directory name, '{}/*' and '*' by file names
  local($1);
  my(@query_expanded) = map($_ eq '*' || $_ eq '{}/*' ? []
                          : m{^ \{ \} ( / .* )? \z}xs ? "$tempdir/parts$1"
                          : $_,  @query_template);
  my $eval_stat;
  eval {
    for (my $k = 0; $k <= $bare_fnames_last;  ) {  # traverse fnames in chunks
      my(@processed_filenames);
      my $arglist_size = 0;  # size of a command with its arguments so far
      for ($command,@query_expanded) { $arglist_size+=length($_)+1 if !ref $_ }
      for (@query_expanded) { @$_ = () if ref $_ }  # reset placeholder lists
      while ($k <= $bare_fnames_last) {  # traverse fnames individually
        my $f = $bare_fnames->[$k];  my $multi = 0;
        if ($one_at_a_time) {  # glob templates may be substrings anywhere
          local($1);  @query_expanded = @query_template;  # start afresh
          s{ ( \{\} (?: / \* )? | \* ) }
           { $1 eq '{}'   ? "$tempdir/parts"
           : $1 eq '{}/*' ? ($multi=1,"$tempdir/parts/$f")
           : $1 eq '*'    ? ($multi=1,$f)  : $1
           }xgse  for @query_expanded;
        } else {
          # collect as many filename arguments as suitable, but at least one
          my $arg_size = 0;
          for (@query_template) {
            if ($_ eq '{}/*') { $arg_size += length("$tempdir/parts/$f") + 1 }
            elsif ($_ eq '*') { $arg_size += length($f) + 1 }
          }
        # do_log(5,"run_av arglist size: %d + %d", $arglist_size,$arg_size);
          if (@processed_filenames && $arglist_size + $arg_size > 4000) {
            # POSIX requires 4 kB as a minimum buffer size for program args
            last;  # enough collected for now, the rest on the next iteration
          }
          # exact matching on command arguments, no substring matches
          for my $j (0..$#query_template) {
            if (ref $query_expanded[$j]) {  # placeholders collecting fnames
              my $arg = $query_template[$j];
              my $repl = $arg eq '{}/*' ? "$tempdir/parts/$f"
                       : $arg eq '*'    ? $f  : undef;
              $multi = 1;
              push(@{$query_expanded[$j]}, untaint($repl));
              $arglist_size += length($repl) + 1;
            }
          }
        }
        $k = $multi ? $k+1 : $bare_fnames_last+1;
        push(@processed_filenames, $multi ? $f : "$tempdir/parts");
        last  if $one_at_a_time;
      }
      # now that arguments have been expanded, invoke the scanner
      my($child_stat,$t_status,$t_output);
      prolong_timer('run_av_scan');  # restart timer
      if (ref $command) {
        my(@q) = map(ref $_ ? @$_ : $_, @query_expanded);
        ll(3) && do_log(3, "run_av Using (%s): (code) %s",
                           $av_name, join(' ',@q));
        # call subroutine directly, passing all our arguments to it
        ($t_status,$t_output) = &$command(!@q ? '' : @q==1 ? $q[0] : \@q, @_);
        prolong_timer('run_av_3');  # restart timer
        $child_stat = 0;  # no spawned process, just declare success
        do_log(4,"run_av (%s) result: %s", $av_name,$t_output);
      } else {
        my($proc_fh,$pid); my $results_ref;
        my $eval_stat2;
        eval {
          my(@q) = map(ref $_ ? @$_ : $_, @query_expanded);
          ll(3) && do_log(3,"run_av Using (%s): %s %s",
                            $av_name,$command,join(' ',@q));
          ($proc_fh,$pid) = run_command(undef, '&1', $command, @q);
          ($results_ref,$child_stat) =
            collect_results($proc_fh,$pid, $av_name,200*1024);
          1;
        } or do { $eval_stat2 = $@ ne '' ? $@ : "errno=$!" };
        undef $proc_fh; undef $pid;
        $error_str = exit_status_str($child_stat,0);
        $t_status = WEXITSTATUS($child_stat)  if defined $child_stat;
        prolong_timer('run_av_4');  # restart timer
        if (defined $eval_stat2) {
          chomp $eval_stat2; $error_str = $eval_stat2;
          do_log(-1, "run_av (%s): %s", $av_name,$eval_stat2);
        }
        if (defined $results_ref)
          { $t_output = $$results_ref; undef $results_ref }
        chomp($t_output); my $t_output_trimmed = $t_output;
        $t_output_trimmed =~ s/\r\n/\n/gs; local($1);
        $t_output_trimmed =~ s/([ \t\n\r])[ \t\n\r]{4,}/$1.../gs;
        $t_output_trimmed = "..." . substr($t_output_trimmed,-800)
          if length($t_output_trimmed) > 800;
        do_log(3, "run_av: %s %s, %s", $command,$error_str,$t_output_trimmed);
      }
      if (!defined($child_stat) || !WIFEXITED($child_stat)) {
        # leave $scan_status undefined, indicating an error
      # braindamaged Perl: empty string implies the last successfully
      # matched regular expression; we must avoid this
      } elsif (defined $sts_infected && (
          ref($sts_infected) eq 'ARRAY' ? (grep($_==$t_status, @$sts_infected))
                              : $sts_infected eq '' ? 1  # avoid m// stupidity
                              : $t_output=~/$sts_infected/m)) {  # is infected
        # test for infected first, in case both expressions match
        $scan_status = 1;  # 'true' indicates virus found
        my(@t_virusnames) = ref($how_to_get_names) eq 'CODE'
                              ? &$how_to_get_names($t_output)
                              : $how_to_get_names eq '' ? ()
                              : $t_output=~/$how_to_get_names/gm;
        @t_virusnames = grep(defined $_, @t_virusnames);
        push(@virusnames, @t_virusnames);
        $output .= $t_output . "\n";
        do_log(2,"run_av (%s): %s INFECTED: %s", $av_name,
                 join(' ',@processed_filenames), join(', ',@t_virusnames) );
      } elsif (!defined($sts_clean)) {  # clean, but inconclusive
        # by convention: undef $sts_clean means result is inconclusive,
        # file appears clean, but continue scanning with other av scanners,
        # the current scanner does not want to vouch for it; useful for a
        # scanner like jpeg checker which tests for one vulnerability only
        do_log(3,"run_av (%s): CLEAN, but inconclusive", $av_name);
      } elsif (ref($sts_clean) eq 'ARRAY'
                    ? (grep($_==$t_status, @$sts_clean))
                    : ""=~/x{0}/ && $t_output=~/$sts_clean/m) {  # is clean
        # 'false' (but defined) indicates no viruses
        $scan_status = 0  if !$scan_status;   # no viruses, no errors
        do_log(3,"run_av (%s): CLEAN", $av_name);
      } else {
      # $error_str = "unexpected $error_str, output=\"$t_output_trimmed\"";
        $error_str = "unexpected $error_str, output=\"$t_output\"";
        do_log(-1,"run_av (%s) FAILED - %s", $av_name,$error_str);
        last;  # error, bail out
      }
      die "Exceeded allowed time\n"  if time >= $deadline;
    }
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  &$post_code(@_)  if defined $post_code;
  @virusnames = ('')  if $scan_status && !@virusnames;  # ensure nonempty list
  do_log(3,"run_av (%s) result: clean", $av_name)
    if defined($scan_status) && !$scan_status;
  chdir($tempdir) or die "Can't chdir to $tempdir: $!";
  if (defined $eval_stat) {
    prolong_timer('run_av_5');  # restart timer
    die "run_av error: $eval_stat\n";
  }
  if (!defined($scan_status) && defined($error_str)) {
    die "$command $error_str";  # die is more informative than a return value
  }
  ($scan_status, $output, \@virusnames);
}

# @av_scanners is a list of n-tuples, where fields semantics is:
#  1. name: an AV scanner plain name, to be used in log and reports;
#  2a. program: a scanner program name; this string will be submitted to
#     subroutine find_external_programs(), which will try to find the full
#     program path name during startup according to a search path in variable
#     $path; if program is not found, this scanner is disabled. Besides a
#     simple string (a full program path name or just the basename to be
#     looked for in PATH), this may be an array ref of alternative program
#     names or full paths - the first match in the list will be used;
#  2b. subroutine: alternatively, this second field may be a subroutine
#     reference, and the whole n-tuple entry is passed to it as args;
#     it should return a triple: ($scan_status,$output,$virusnames_ref),
#     where:
#     - $scan_status is: true if a virus was found, 0 if no viruses,
#       undef if scanner was unable to complete its job (failed);
#     - $output is an optional result string to appear in logging and macro %v;
#     - $virusnames_ref is a ref to a list of detected virus names (may be
#       undef or a ref to an empty list);
#  3. args: command arguments to be given to the scanner program;
#     a substring {} will be replaced by the directory name to be scanned, i.e.
#     "$tempdir/parts", a "*" will be replaced by base file names of parts;
#  4. clean: an array ref of av scanner exit status values, or a regexp
#     (to be matched against scanner output), indicating NO VIRUSES found;
#     a special case is a value undef, which does not claim file to be clean
#     (i.e. it never matches, similar to []), but suppresses a failure warning;
#     to be used when the result is inconclusive (useful for specialized and
#     quick partial scanners such as jpeg checker);
#  5. infected: an array ref of av scanner exit status values, or a regexp
#     (to be matched against scanner output), indicating VIRUSES WERE FOUND;
#     a value undef may be used and it never matches (for consistency with 4.);
#     Note: the virus match prevails over a 'not found' match, so it is safe
#     even if the no. 4. matches for viruses too;
#  6. virus name: a regexp (to be matched against scanner output), returning
#     a list of virus names found, or a sub ref, returning such a list when
#     given scanner output as argument;
#  7. and 8.: (optional) subroutines to be executed before and after scanner
#     (e.g. to set environment or current directory);
#     see examples for these at KasperskyLab AVP and NAI uvscan.

sub virus_scan($$) {
  my($msginfo,$firsttime) = @_;
  my $tempdir = $msginfo->mail_tempdir;
  my($scan_status,$output,@virusname);
  my(@detecting_scanners,@av_scanners_results);
  my $anyone_done = 0; my $anyone_tried = 0;
  my($bare_fnames_ref,$names_to_parts);
  my $j; my $tier = 'primary';
  for my $av (@{ca('av_scanners')}, "\000", @{ca('av_scanners_backup')}) {
    next  if !defined $av;
    if ($av eq "\000") {  # 'magic' separator between lists
      last  if $anyone_done;
      do_log(-1,"WARN: all %s virus scanners failed, considering backups",
                $tier);
      $tier = 'secondary';  next;
    }
    next  if !ref $av || !defined $av->[1];
    if (!defined $bare_fnames_ref) {  # first time: collect file names to scan
      my $parts_root = $msginfo->parts_root;
      ($bare_fnames_ref,$names_to_parts) =
        files_to_scan("$tempdir/parts", $parts_root);
      if (!@$bare_fnames_ref) {
        do_log(2, "Not calling virus scanners, no files to scan in %s/parts",
                  $tempdir);
      } else {
        do_log(5, "Calling virus scanners, %d files to scan in %s/parts",
                  scalar(@$bare_fnames_ref), $tempdir);
      }
    }
    my($scanner_name,$command) = @$av;
    $anyone_tried = 1; my($this_status,$this_output,$this_vn);
    if (!@$bare_fnames_ref) {  # no files to scan?
      ($this_status,$this_output,$this_vn) = (0, '', undef);  # declare clean
    } else {  # call virus scanner
      do_log(5, "invoking av-scanner %s", $scanner_name);
      eval {
        ($this_status,$this_output,$this_vn) = ref $command eq 'CODE'
            ? &$command($bare_fnames_ref,$names_to_parts,$tempdir, @$av)
            :    run_av($bare_fnames_ref,$names_to_parts,$tempdir, @$av);
        1;
      } or do {
        my $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;
        $err = sprintf("%s av-scanner FAILED: %s", $scanner_name, $err);
        do_log(-1, "%s", $err);
        $this_status = undef;
      };
    }
    $anyone_done = 1  if defined $this_status;
    $j++; section_time("AV-scan-$j");
    if ($this_status && $this_vn && @$this_vn) {
      @$this_vn = unique_list($this_vn);
      # virus is reported by this scanner; is it for real, or is it just spam?
      my(@spam_hits);  my $vnts = ca('virus_name_to_spam_score_maps');
      @spam_hits =  # map each reported virus name to spam score or to undef
        map(scalar(lookup2(0,$_,$vnts)), @$this_vn)  if ref $vnts;
      if (@spam_hits && !grep(!defined($_), @spam_hits)) {  # all defined
        # AV scanner did trigger, but all provided names are actually spam!
        my(%seen);
        for my $r (@{$msginfo->per_recip_data}) {
          my $spam_tests = $r->spam_tests;
          if ($spam_tests) {
            local($1,$2);
            for (split(/,/, join(',',map($$_,@$spam_tests)))) {
              $seen{$1} = $2  if /^AV\.([^=]*)=([0-9.+-]+)\z/;
            }
          }
        }
        my(@vnms,@hits);
        # remove already detected virus names and duplicates from the list
        for my $j (0..$#$this_vn) {
          my $vname = $this_vn->[$j];
          if (!exists($seen{$vname})) {
            push(@vnms,$vname); push(@hits,$spam_hits[$j]);
            $seen{$vname} = $spam_hits[$j];  # keep only one copy
          }
        }
        @$this_vn = @vnms; @spam_hits = @hits;
        if (!@spam_hits) {
          do_log(2,"Turning AV infection into a spam report, ".
                   "name already accounted for");
        } else {
          my $spam_level = max(@spam_hits);
          my $spam_tests = join(',',
                    map(sprintf("AV:%s=%s", $this_vn->[$_], $spam_hits[$_]),
                        (0..$#$this_vn) ));
          for my $r (@{$msginfo->per_recip_data}) {
            $r->spam_level( ($r->spam_level || 0) + $spam_level );
            if (!$r->spam_tests) {
              $r->spam_tests([ \$spam_tests ]);
            } else {
              push(@{$r->spam_tests}, \$spam_tests);
            }
          }
          my $spam_report = $spam_tests;
          my $spam_summary =
            sprintf("AV scanner %s reported spam (not infection):\n%s\n",
                    $scanner_name, join(',',@$this_vn));
          do_log(2,"Turning AV infection into a spam report: score=%s, %s",
                   $spam_level, $spam_tests);
          if (defined($msginfo->spam_report)||defined($msginfo->spam_summary)){
            $spam_report = $msginfo->spam_report . ', ' . $spam_report
              if $msginfo->spam_report ne '';
            $spam_summary = $msginfo->spam_summary . "\n\n" . $spam_summary
              if $msginfo->spam_summary ne '';
          }
          $msginfo->spam_report($spam_report);
          $msginfo->spam_summary($spam_summary);
        }
        $this_status = 0; @$this_vn = (); # TURN OFF ALERT for this AV scanner!
      }
    }
    push(@av_scanners_results,
         [$av, $this_status, !$this_vn ? () : @$this_vn]);
    if ($this_status) {  # a virus detected by this scanner, really! (not spam)
      push(@detecting_scanners, $scanner_name);
      if (!@virusname) {  # store results of the first scanner detecting
        @virusname = @$this_vn  if $this_vn;
        $scan_status = $this_status; $output = $this_output;
      }
      last  if c('first_infected_stops_scan');  # stop now if we found a virus?
    } elsif (!defined($scan_status)) {  # tentatively keep regardless of status
      $scan_status = $this_status; $output = $this_output;
    }
  }
  if (ll(2) && @virusname && @detecting_scanners) {
    my(@ds) = @detecting_scanners;  s/,/;/ for @ds;  # facilitates parsing
    do_log(2, "virus_scan: (%s), detected by %d scanners: %s",
              join(', ',@virusname), scalar(@ds), join(', ',@ds));
  }
  $output =~ s{\Q$tempdir\E/parts/?}{}gs  if defined $output;  # hide path info
  if (!$anyone_tried) { die "NO VIRUS SCANNERS AVAILABLE\n" }
  elsif (!$anyone_done) { die "ALL VIRUS SCANNERS FAILED\n" }
  ($scan_status, $output, \@virusname,
   \@detecting_scanners, \@av_scanners_results);  # return a 5-tuple
}

# return a ref to a list of files to be scanned in a given directory
#
sub files_to_scan($$) {
  my($dir,$parts_root) = @_;
  my $names_to_parts = {};  # a hash that maps base file names
                            # to Amavis::Unpackers::Part object
  # traverse decomposed parts tree breadth-first, match it to actual files
  for (my $part, my(@unvisited)=($parts_root);
       @unvisited and $part=shift(@unvisited);
       push(@unvisited,@{$part->children}))
    { $names_to_parts->{$part->base_name} = $part  if $part ne $parts_root }
  my $bare_fnames_ref = []; my(%bare_fnames);
  # traverse parts directory and check for actual files
  local(*DIR); opendir(DIR,$dir) or die "Can't open directory $dir: $!";
  # modifying a directory while traversing it can cause surprises, avoid;
  # avoid slurping the whole directory contents into memory
  my($f, @rmfiles, @rmdirs);
  while (defined($f = readdir(DIR))) {
    next  if $f eq '.' || $f eq '..';
    my $fname = $dir . '/' . $f;
    my(@stat_list) = lstat($fname); my $errn = @stat_list ? 0 : 0+$!;
    next  if $errn == ENOENT;
    if ($errn) { die "files_to_scan: file $fname inaccessible: $!" }
    add_entropy(@stat_list);
    if (!-r _) {  # attempting to gain read access to the file
      do_log(3,"files_to_scan: attempting to gain read access to %s", $fname);
      chmod(0750, untaint($fname))
        or die "files_to_scan: Can't change protection on $fname: $!";
      $errn = lstat($fname) ? 0 : 0+$!;
      if ($errn) { die "files_to_scan: file $fname inaccessible: $!" }
      if (!-r _) { die "files_to_scan: file $fname not readable" }
    }
    if (!-f _ || !exists $names_to_parts->{$f}) {
      # not a regular file or unexpected
      my $what = -l _ ? 'symlink' : -d _ ? 'directory' : -f _ ? 'file'
                 : 'non-regular file';
      my $msg = "removing unexpected $what $fname";
      $msg .= ", it has no corresponding parts object"
        if !exists $names_to_parts->{$f};
      do_log(-1, "WARN: files_to_scan: %s", $msg);
      if (-d _) { push(@rmdirs, $f) } else { push(@rmfiles, $f) }
    } elsif (-z _) {
      # empty file
    } else {
      if ($f !~ /^[A-Za-z0-9_.-]+\z/s) {
        do_log(-1,"WARN: files_to_scan: unexpected/suspicious file name: %s",
                  $f);
      }
      push(@$bare_fnames_ref,$f); $bare_fnames{$f} = 1;
    }
  }
  closedir(DIR) or die "Error closing directory $dir: $!";
  for my $f (@rmfiles) {
    my $fname = $dir . '/' . untaint($f);
    do_log(5,"files_to_scan: deleting file %s", $fname);
    unlink($fname) or die "Can't delete $fname: $!";
  }
  undef @rmfiles;
  for my $d (@rmdirs) {
    my $dname = $dir . '/' . untaint($d);
    do_log(5,"files_to_scan: deleting directory %s", $dname);
    rmdir_recursively($dname);
  }
  undef @rmdirs;
  # remove entries from %$names_to_parts that have no corresponding files
  my($fname,$part);
  while ( ($fname,$part) = each %$names_to_parts ) {
    next  if exists $bare_fnames{$fname};
    if (ll(4) && $part->exists) {
      my $type_short = $part->type_short;
      do_log(4,"files_to_scan: info: part %s (%s) no longer present",
          $fname, (!ref $type_short ? $type_short : join(', ',@$type_short)) );
    }
    delete $names_to_parts->{$fname}; # delete is allowed for the current elem.
  }
  ($bare_fnames_ref, $names_to_parts);
}

1;