debianqueued

#!/usr/bin/perl -w
#
# debianqueued -- daemon for managing Debian upload queues
#
# Copyright (C) 1997 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>
# Copyright (C) 2001-2007 Ryan Murray <rmurray@debian.org>
# Copyright (C) 2008 Thomas Viehmann <tv@beamnet.de>
#
# 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 or
# (at your option) any later version.
# This program comes with ABSOLUTELY NO WARRANTY!
#

require 5.002;
use strict;
use POSIX;
use POSIX qw( strftime sys_stat_h sys_wait_h signal_h );
use Net::Ping;
use Net::FTP;
use Socket qw( PF_INET AF_INET SOCK_STREAM );
use Config;
use Sys::Hostname;

setlocale(&POSIX::LC_ALL, "C");

# ---------------------------------------------------------------------------
#								configuration
# ---------------------------------------------------------------------------

package conf;
( $conf::queued_dir = ( ( $0 !~ m,^/, ) ? POSIX::getcwd() . "/" : "" ) . $0 )
  =~ s,/[^/]+$,,;
require "$conf::queued_dir/config";
my $junk = $conf::debug;    # avoid spurious warnings about unused vars
$junk = $conf::ssh_key_file;
$junk = $conf::stray_remove_timeout;
$junk = $conf::problem_report_timeout;
$junk = $conf::queue_delay;
$junk = $conf::keep_files;
$junk = $conf::valid_files;
$junk = $conf::max_upload_retries;
$junk = $conf::upload_delay_1;
$junk = $conf::upload_delay_2;
$junk = $conf::ar;
$junk = $conf::gzip;
$junk = $conf::cp;
$junk = $conf::check_md5sum;

#$junk = $conf::ls;
$junk         = $conf::chmod;
$junk         = $conf::ftpdebug;
$junk         = $conf::ftptimeout;
$junk         = $conf::no_changes_timeout;
$junk         = @conf::nonus_packages;
$junk         = @conf::test_binaries;
$junk         = @conf::maintainer_mail;
$junk         = @conf::targetdir_delayed;
$junk         = $conf::mail ||= '/usr/sbin/sendmail';
$conf::target = "localhost" if $conf::upload_method eq "copy";

package main;

( $main::progname = $0 ) =~ s,.*/,,;

($main::hostname, undef, undef, undef, undef) = gethostbyname(hostname());

my %packages = ();

# extract -r and -k args
$main::arg = "";
if ( @ARGV == 1 && $ARGV[0] =~ /^-[rk]$/ ) {
  $main::arg = ( $ARGV[0] eq '-k' ) ? "kill" : "restart";
  shift @ARGV;
}

# test for another instance of the queued already running
my ( $pid, $delayed_dirs, $adelayedcore );
if ( open( PIDFILE, "<$conf::pidfile" ) ) {
  chomp( $pid = <PIDFILE> );
  close(PIDFILE);
  if ( !$pid ) {

    # remove stale pid file
    unlink($conf::pidfile);
  } elsif ($main::arg) {
    local ($|) = 1;
    print "Killing running daemon (pid $pid) ...";
    kill( 15, $pid );
    my $cnt = 20;
    while ( kill( 0, $pid ) && $cnt-- > 0 ) {
      sleep 1;
      print ".";
    }
    if ( kill( 0, $pid ) ) {
      print " failed!\nProcess $pid still running.\n";
      exit 1;
    }
    print "ok\n";
    if ( -e "$conf::incoming/core" ) {
      unlink("$conf::incoming/core");
      print "(Removed core file)\n";
    }
    for ( $delayed_dirs = 0 ;
          $delayed_dirs <= $conf::max_delayed ;
          $delayed_dirs++ )
    {
      $adelayedcore =
        sprintf( "$conf::incoming_delayed/core", $delayed_dirs );
      if ( -e $adelayedcore ) {
        unlink($adelayedcore);
        print "(Removed core file)\n";
      }
    } ## end for ( $delayed_dirs = 0...
    exit 0 if $main::arg eq "kill";
  } else {
    die "Another $main::progname is already running (pid $pid)\n"
      if $pid && kill( 0, $pid );
  }
} elsif ( $main::arg eq "kill" ) {
  die "No daemon running\n";
} elsif ( $main::arg eq "restart" ) {
  print "(No daemon running; starting anyway)\n";
}

# if started without arguments (initial invocation), then fork
if ( !@ARGV ) {

  # now go to background
  die "$main::progname: fork failed: $!\n"
    unless defined( $pid = fork );
  if ($pid) {

    # parent: wait for signal from child (SIGCHLD or SIGUSR1) and exit
    my $sigset = POSIX::SigSet->new();
    $sigset->emptyset();
    $SIG{"CHLD"} = sub { };
    $SIG{"USR1"} = sub { };
    POSIX::sigsuspend($sigset);
    waitpid( $pid, WNOHANG );
    if ( kill( 0, $pid ) ) {
      print "Daemon (on $main::hostname) started in background (pid $pid)\n";
      exit 0;
    } else {
      exit 1;
    }
  } else {

    # child
    setsid;
    if ( $conf::upload_method eq "ssh" ) {

      # exec an ssh-agent that starts us again
      # force shell to be /bin/sh, ssh-agent may base its decision
      # whether to use a fd or a Unix socket on the shell...
      $ENV{"SHELL"} = "/bin/sh";
      exec $conf::ssh_agent, $0, "startup", getppid();
      die "$main::progname: Could not exec $conf::ssh_agent: $!\n";
    } else {

      # no need to exec, just set up @ARGV as expected below
      @ARGV = ( "startup", getppid() );
    }
  } ## end else [ if ($pid)
} ## end if ( !@ARGV )
die "Please start without any arguments.\n"
  if @ARGV != 2 || $ARGV[0] ne "startup";
my $parent_pid = $ARGV[1];

do {
  my $version;
  ( $version = 'Release: 0.95' ) =~ s/\$ ?//g;
  print "debianqueued $version\n";
};

# check if all programs exist
my $prg;
foreach $prg ( $conf::gpg, $conf::ssh, $conf::scp, $conf::ssh_agent,
               $conf::ssh_add, $conf::md5sum, $conf::mail, $conf::mkfifo )
{
  die "Required program $prg doesn't exist or isn't executable\n"
    if !-x $prg;

  # check for correct upload method
  die "Bad upload method '$conf::upload_method'.\n"
    if $conf::upload_method ne "ssh"
      && $conf::upload_method ne "ftp"
      && $conf::upload_method ne "copy";
  die "No keyrings\n" if !@conf::keyrings;

} ## end foreach $prg ( $conf::gpg, ...
die "statusfile path must be absolute."
  if $conf::statusfile !~ m,^/,;
die "upload and target queue paths must be absolute."
  if $conf::incoming !~ m,^/,
    || $conf::incoming_delayed !~ m,^/,
    || $conf::targetdir !~ m,^/,
    || $conf::targetdir_delayed !~ m,^/,;

# ---------------------------------------------------------------------------
#							   initializations
# ---------------------------------------------------------------------------

# prototypes
sub calc_delta();
sub check_dir();
sub get_filelist_from_known_good_changes($);
sub age_delayed_queues();
sub process_changes($\@);
sub process_commands($);
sub age_delayed_queues();
sub is_on_target($\@);
sub copy_to_target(@);
sub pgp_check($);
sub check_alive(;$);
sub check_incoming_writable();
sub fork_statusd();
sub write_status_file();
sub print_status($$$$$$);
sub format_status_num(\$$);
sub format_status_str(\$$);
sub send_status();
sub ftp_open();
sub ftp_cmd($@);
sub ftp_close();
sub ftp_response();
sub ftp_code();
sub ftp_error();
sub ssh_cmd($);
sub scp_cmd(@);
sub local_cmd($;$);
sub check_alive(;$);
sub check_incoming_writable();
sub rm(@);
sub md5sum($);
sub is_debian_file($);
sub get_maintainer($);
sub debian_file_stem($);
sub msg($@);
sub debug(@);
sub init_mail(;$);
sub finish_mail();
sub send_mail($$$);
sub try_to_get_mail_addr($$);
sub format_time();
sub print_time($);
sub block_signals();
sub unblock_signals();
sub close_log($);
sub kid_died($);
sub restart_statusd();
sub fatal_signal($);

$ENV{"PATH"} = "/bin:/usr/bin";
$ENV{"IFS"} = "" if defined( $ENV{"IFS"} && $ENV{"IFS"} ne "" );

# constants for stat
sub ST_DEV()   { 0 }
sub ST_INO()   { 1 }
sub ST_MODE()  { 2 }
sub ST_NLINK() { 3 }
sub ST_UID()   { 4 }
sub ST_GID()   { 5 }
sub ST_RDEV()  { 6 }
sub ST_SIZE()  { 7 }
sub ST_ATIME() { 8 }
sub ST_MTIME() { 9 }
sub ST_CTIME() { 10 }

# fixed lengths of data items passed over status pipe
sub STATNUM_LEN() { 30 }
sub STATSTR_LEN() { 128 }

# init list of signals
defined $Config{sig_name}
  or die "$main::progname: No signal list defined!\n";
my $i = 0;
my $name;
foreach $name ( split( ' ', $Config{sig_name} ) ) {
  $main::signo{$name} = $i++;
}

@main::fatal_signals = qw( INT QUIT ILL TRAP ABRT BUS FPE USR2 SEGV PIPE
  TERM XCPU XFSZ PWR );

$main::block_sigset = POSIX::SigSet->new;
$main::block_sigset->addset( $main::signo{"INT"} );
$main::block_sigset->addset( $main::signo{"TERM"} );

# some constant net stuff
$main::tcp_proto = ( getprotobyname('tcp') )[2]
  or die "Cannot get protocol number for 'tcp'\n";
my $used_service = ( $conf::upload_method eq "ssh" ) ? "ssh" : "ftp";
$main::echo_port = ( getservbyname( $used_service, 'tcp' ) )[2]
  or die "Cannot get port number for service '$used_service'\n";

# clear queue of stored mails
@main::stored_mails = ();

# run ssh-add to bring the key into the agent (will use stdin/stdout)
if ( $conf::upload_method eq "ssh" ) {
  system "$conf::ssh_add $conf::ssh_key_file"
    and die "$main::progname: Running $conf::ssh_add failed "
    . "(exit status ", $? >> 8, ")\n";
}

# change to queue dir
chdir($conf::incoming)
  or die "$main::progname: cannot cd to $conf::incoming: $!\n";

# needed before /dev/null redirects, some system send a SIGHUP when loosing
# the controlling tty
$SIG{"HUP"} = "IGNORE";

# open logfile, make it unbuffered
open( LOG, ">>$conf::logfile" )
  or die "Cannot open my logfile $conf::logfile: $!\n";
chmod( 0644, $conf::logfile )
  or die "Cannot set modes of $conf::logfile: $!\n";
select( ( select(LOG), $| = 1 )[0] );

sleep(1);
$SIG{"HUP"} = \&close_log;

# redirect stdin, ... to /dev/null
open( STDIN, "</dev/null" )
  or die "$main::progname: Can't redirect stdin to /dev/null: $!\n";
open( STDOUT, ">&LOG" )
  or die "$main::progname: Can't redirect stdout to $conf::logfile: $!\n";
open( STDERR, ">&LOG" )
  or die "$main::progname: Can't redirect stderr to $conf::logfile: $!\n";

# ok, from this point usually no "die" anymore, stderr is gone!
msg( "log", "daemon (pid $$) (on $main::hostname) started\n" );

# initialize variables used by send_status before launching the status daemon
$main::dstat = "i";
format_status_num( $main::next_run, time + 10 );
format_status_str( $main::current_changes, "" );
check_alive();
$main::incoming_writable = 1;    # assume this for now

# start the daemon watching the 'status' FIFO
if ( $conf::statusfile && $conf::statusdelay == 0 ) {
  $main::statusd_pid = fork_statusd();
  $SIG{"CHLD"}       = \&kid_died;       # watch out for dead status daemon
                                         # SIGUSR1 triggers status info
  $SIG{"USR1"}       = \&send_status;
} ## end if ( $conf::statusfile...
$main::maind_pid = $$;

END {
  kill( $main::signo{"ABRT"}, $$ )
    if defined $main::signo{"ABRT"};
}

# write the pid file
open( PIDFILE, ">$conf::pidfile" )
  or msg( "log", "Can't open $conf::pidfile: $!\n" );
printf PIDFILE "%5d\n", $$;
close(PIDFILE);
chmod( 0644, $conf::pidfile )
  or die "Cannot set modes of $conf::pidfile: $!\n";

# other signals will just log an error and exit
foreach (@main::fatal_signals) {
  $SIG{$_} = \&fatal_signal;
}

# send signal to user-started process that we're ready and it can exit
kill( $main::signo{"USR1"}, $parent_pid );

# ---------------------------------------------------------------------------
#								 the mainloop
# ---------------------------------------------------------------------------

# default to classical incoming/target
$main::current_incoming  = $conf::incoming;
$main::current_targetdir = $conf::targetdir;

$main::dstat = "i";
write_status_file() if $conf::statusdelay;
while (1) {

  # ping target only if there is the possibility that we'll contact it (but
  # also don't wait too long).
  my @have_changes = <*.changes *.commands>;
  for ( my $delayed_dirs = 0 ;
        $delayed_dirs <= $conf::max_delayed ;
        $delayed_dirs++ )
  {
    my $adelayeddir = sprintf( "$conf::incoming_delayed", $delayed_dirs );
    push( @have_changes, <$adelayeddir/*.changes> );
  } ## end for ( my $delayed_dirs ...
  check_alive()
    if @have_changes || ( time - $main::last_ping_time ) > 8 * 60 * 60;

  if ( @have_changes && $main::target_up ) {
    check_incoming_writable if !$main::incoming_writable;
    check_dir() if $main::incoming_writable;
  }
  $main::dstat = "i";
  write_status_file() if $conf::statusdelay;

  if ( $conf::upload_method eq "copy" ) {
    age_delayed_queues();
  }

  # sleep() returns if we received a signal (SIGUSR1 for status FIFO), so
  # calculate the end time once and wait for it being reached.
  format_status_num( $main::next_run, time + $conf::queue_delay );
  my $delta;
  while ( ( $delta = calc_delta() ) > 0 ) {
    debug("mainloop sleeping $delta secs");
    sleep($delta);

    # check if statusd died, if using status FIFO, or update status file
    if ($conf::statusdelay) {
      write_status_file();
    } else {
      restart_statusd();
    }
  } ## end while ( ( $delta = calc_delta...
} ## end while (1)

sub calc_delta() {
  my $delta;

  $delta = $main::next_run - time;
  $delta = $conf::statusdelay
    if $conf::statusdelay && $conf::statusdelay < $delta;
  return $delta;
} ## end sub calc_delta()

# ---------------------------------------------------------------------------
#							main working functions
# ---------------------------------------------------------------------------

#
# main function for checking the incoming dir
#
sub check_dir() {
  my ( @files, @changes, @keep_files, @this_keep_files, @stats, $file,
       $adelay );

  debug("starting checkdir");
  $main::dstat = "c";
  write_status_file() if $conf::statusdelay;

  # test if needed binaries are available; this is if they're on maybe
  # slow-mounted NFS filesystems
  foreach (@conf::test_binaries) {
    next if -f $_;

    # maybe the mount succeeds now
    sleep 5;
    next if -f $_;
    msg( "log", "binary test failed for $_; delaying queue run\n" );
    goto end_run;
  } ## end foreach (@conf::test_binaries)

  for ( $adelay = -1 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
    if ( $adelay == -1 ) {
      $main::current_incoming       = $conf::incoming;
      $main::current_incoming_short = "";
      $main::current_targetdir      = $conf::targetdir;
    } else {
      $main::current_incoming = sprintf( $conf::incoming_delayed, $adelay );
      $main::current_incoming_short = sprintf( "DELAYED/%d-day", $adelay );
      $main::current_targetdir = sprintf( $conf::targetdir_delayed, $adelay );
    }

    # need to clear directory specific variables
    undef(@keep_files);
    undef(@this_keep_files);

    chdir($main::current_incoming)
      or (
           msg(
                "log",
                "Cannot change to dir "
                  . "${main::current_incoming_short}: $!\n"
              ),
           return
         );

    # look for *.commands files but not in delayed queues
    if ( $adelay == -1 ) {
      foreach $file (<*.commands>) {
        init_mail($file);
        block_signals();
        process_commands($file);
        unblock_signals();
        $main::dstat = "c";
        write_status_file() if $conf::statusdelay;
        finish_mail();
      } ## end foreach $file (<*.commands>)
    } ## end if ( $adelay == -1 )
    opendir( INC, "." )
      or (
           msg(
                "log", "Cannot open dir ${main::current_incoming_short}: $!\n"
              ),
           return
         );
    @files = readdir(INC);
    closedir(INC);

    # process all .changes files found
    @changes = grep /\.changes$/, @files;
    push( @keep_files, @changes );    # .changes files aren't stray
    foreach $file (@changes) {
      init_mail($file);

      # wrap in an eval to allow jumpbacks to here with die in case
      # of errors
      block_signals();
      eval { process_changes( $file, @this_keep_files ); };
      unblock_signals();
      msg( "log,mail", $@ ) if $@;
      $main::dstat = "c";
      write_status_file() if $conf::statusdelay;

      # files which are ok in conjunction with this .changes
      debug("$file tells to keep @this_keep_files");
      push( @keep_files, @this_keep_files );
      finish_mail();

      # break out of this loop if the incoming dir has become unwritable
      goto end_run if !$main::incoming_writable;
    } ## end foreach $file (@changes)
    ftp_close() if $conf::upload_method eq "ftp";

    # find files which aren't related to any .changes
    foreach $file (@files) {

      # filter out files we never want to delete
      next if !-f $file ||    # may have disappeared in the meantime
             $file eq "."
          || $file eq ".."
          || ( grep { $_ eq $file } @keep_files )
          || $file =~ /$conf::keep_files/;

      # Delete such files if they're older than
      # $stray_remove_timeout; they could be part of an
      # yet-incomplete upload, with the .changes still missing.
      # Cannot send any notification, since owner unknown.
      next if !( @stats = stat($file) );
      my $age = time - $stats[ST_MTIME];
      my ( $maint, $pattern, @job_files );
      if (    $file =~ /^junk-for-writable-test/
           || $file !~ m,$conf::valid_files,
           || $age >= $conf::stray_remove_timeout )
      {
        msg( "log",
             "Deleted stray file ${main::current_incoming_short}/$file\n" )
          if rm($file);
      } elsif (
        $age > $conf::no_changes_timeout
        && is_debian_file($file)
        &&

        # not already reported
          !( $stats[ST_MODE] & S_ISGID )
        && ( $pattern   = debian_file_stem($file) )
        && ( @job_files = glob($pattern) )
        &&

        # If a .changes is in the list, it has the same stem as the
        # found file (probably a .orig.tar.gz). Don't report in this
        # case.
        !( grep( /\.changes$/, @job_files ) )
              )
      {
        $maint = get_maintainer($file);

        # Don't send a mail if this looks like the recompilation of a
        # package for a non-i386 arch. For those, the maintainer field is
        # useless :-(
        if ( !grep( /(\.dsc|_(i386|all)\.deb)$/, @job_files ) ) {
          msg( "log", "Found an upload without .changes and with no ",
               ".dsc file\n" );
          msg( "log",
               "Not sending a report, because probably ",
               "recompilation job\n" );
        } elsif ($maint) {
          init_mail();
          $main::mail_addr = $maint;
          $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
          $main::mail_subject =
            "Incomplete upload found in " . "Debian upload queue";
          msg(
               "mail",
               "Probably you are the uploader of the following "
                 . "file(s) in\n"
             );
          msg( "mail", "the Debian upload queue directory:\n  " );
          msg( "mail", join( "\n  ", @job_files ), "\n" );
          msg(
               "mail",
               "This looks like an upload, but a .changes file "
                 . "is missing, so the job\n"
             );
          msg( "mail", "cannot be processed.\n\n" );
          msg(
               "mail",
               "If no .changes file arrives within ",
               print_time( $conf::stray_remove_timeout - $age ),
               ", the files will be deleted.\n\n"
             );
          msg(
               "mail",
               "If you didn't upload those files, please just "
                 . "ignore this message.\n"
             );
          finish_mail();
          msg(
               "log",
               "Sending problem report for an upload without a "
                 . ".changes\n"
             );
          msg( "log", "Maintainer: $maint\n" );
        } else {
          msg(
               "log",
               "Found an upload without .changes, but can't "
                 . "find a maintainer address\n"
             );
        } ## end else [ if ( !grep( /(\.dsc|_(i386|all)\.deb)$/...
        msg( "log", "Files: @job_files\n" );

        # remember we already have sent a mail regarding this file
        foreach (@job_files) {
          my @st = stat($_);
          next if !@st;    # file may have disappeared in the meantime
          chmod +( $st[ST_MODE] |= S_ISGID ), $_;
        }
      } else {
        debug(
"found stray file ${main::current_incoming_short}/$file, deleting in ",
          print_time( $conf::stray_remove_timeout - $age )
        );
      } ## end else [ if ( $file =~ /^junk-for-writable-test/...
    } ## end foreach $file (@files)
  } ## end for ( $adelay = -1 ; $adelay...
  chdir($conf::incoming);

end_run:
  $main::dstat = "i";
  write_status_file() if $conf::statusdelay;
} ## end sub check_dir()

sub get_filelist_from_known_good_changes($) {
  my $changes = shift;

  local (*CHANGES);
  my (@filenames);

  # parse the .changes file
  open( CHANGES, "<$changes" )
    or die "$changes: $!\n";
outer_loop: while (<CHANGES>) {
    if (/^Files:/i) {
      while (<CHANGES>) {
        redo outer_loop if !/^\s/;
        my @field = split(/\s+/);
        next if @field != 6;

        # forbid shell meta chars in the name, we pass it to a
        # subshell several times...
        $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/;
        if ( $1 ne $field[5] ) {
          msg( "log", "found suspicious filename $field[5]\n" );
          next;
        }
        push( @filenames, $field[5] );
      } ## end while (<CHANGES>)
    } ## end if (/^Files:/i)
  } ## end while (<CHANGES>)
  close(CHANGES);
  return @filenames;
} ## end sub get_filelist_from_known_good_changes($)

#
# process one .changes file
#
sub process_changes($\@) {
  my $changes   = shift;
  my $keep_list = shift;
  my (
       $pgplines,     @files,     @filenames,  @changes_stats,
       $failure_file, $retries,   $last_retry, $upload_time,
       $file,         $do_report, $ls_l,       $problems_reported,
       $errs,         $pkgname,   $signator
     );
  local (*CHANGES);
  local (*FAILS);

  format_status_str( $main::current_changes,
                     "$main::current_incoming_short/$changes" );
  $main::dstat = "c";
  write_status_file() if $conf::statusdelay;

  @$keep_list = ();
  msg( "log", "processing ${main::current_incoming_short}/$changes\n" );

  # parse the .changes file
  open( CHANGES, "<$changes" )
    or die "Cannot open ${main::current_incoming_short}/$changes: $!\n";
  $pgplines        = 0;
  $main::mail_addr = "";
  @files           = ();
outer_loop: while (<CHANGES>) {
    if (/^---+(BEGIN|END) PGP .*---+$/) {
      ++$pgplines;
    } elsif (/^Maintainer:\s*/i) {
      chomp( $main::mail_addr = $' );
      $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
    } elsif (/^Source:\s*/i) {
      chomp( $pkgname = $' );
      $pkgname =~ s/\s+$//;
      $main::packages{$pkgname}++;
    } elsif (/^Files:/i) {
      while (<CHANGES>) {
        redo outer_loop if !/^\s/;
        my @field = split(/\s+/);
        next if @field != 6;

        # forbid shell meta chars in the name, we pass it to a
        # subshell several times...
        $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/;
        if ( $1 ne $field[5] ) {
          msg( "log", "found suspicious filename $field[5]\n" );
          msg(
            "mail",
"File '$field[5]' mentioned in $main::current_incoming_short/$changes\n",
            "has bad characters in its name. Removed.\n"
          );
          rm( $field[5] );
          next;
        } ## end if ( $1 ne $field[5] )
        push(
              @files,
              {
                md5  => $field[1],
                size => $field[2],
                name => $field[5]
              }
            );
        push( @filenames, $field[5] );
        debug( "includes file $field[5], size $field[2], ", "md5 $field[1]" );
      } ## end while (<CHANGES>)
    } ## end elsif (/^Files:/i)
  } ## end while (<CHANGES>)
  close(CHANGES);

  # tell check_dir that the files mentioned in this .changes aren't stray,
  # we know about them somehow
  @$keep_list = @filenames;

  # some consistency checks
  if ( !$main::mail_addr ) {
    msg( "log,mail",
"$main::current_incoming_short/$changes doesn't contain a Maintainer: field; "
        . "cannot process\n" );
    goto remove_only_changes;
  } ## end if ( !$main::mail_addr)
  if ( $main::mail_addr !~ /^(buildd_\S+-\S+|\S+\@\S+\.\S+)/ ) {

    # doesn't look like a mail address, maybe only the name
    my ( $new_addr, @addr_list );
    if ( $new_addr = try_to_get_mail_addr( $main::mail_addr, \@addr_list ) ) {

      # substitute (unique) found addr, but give a warning
      msg(
           "mail",
           "(The Maintainer: field didn't contain a proper "
             . "mail address.\n"
         );
      msg(
           "mail",
           "Looking for `$main::mail_addr' in the Debian "
             . "keyring gave your address\n"
         );
      msg( "mail", "as unique result, so I used this.)\n" );
      msg( "log",
           "Substituted $new_addr for malformed " . "$main::mail_addr\n" );
      $main::mail_addr = $new_addr;
    } else {

      # not found or not unique: hold the job and inform queue maintainer
      my $old_addr = $main::mail_addr;
      $main::mail_addr = $conf::maintainer_mail;
      msg(
        "mail",
"The job ${main::current_incoming_short}/$changes doesn't have a correct email\n"
      );
      msg( "mail", "address in the Maintainer: field:\n" );
      msg( "mail", "  $old_addr\n" );
      msg( "mail", "A check for this in the Debian keyring gave:\n" );
      msg( "mail",
           @addr_list
           ? "  " . join( ", ", @addr_list ) . "\n"
           : "  nothing\n" );
      msg( "mail", "Please fix this manually\n" );
      msg(
        "log",
"Bad Maintainer: field in ${main::current_incoming_short}/$changes: $old_addr\n"
      );
      goto remove_only_changes;
    } ## end else [ if ( $new_addr = try_to_get_mail_addr...
  } ## end if ( $main::mail_addr ...
  if ( $pgplines < 3 ) {
    msg(
        "log,mail",
        "$main::current_incoming_short/$changes isn't signed with PGP/GnuPG\n"
       );
    msg( "log", "(uploader $main::mail_addr)\n" );
    goto remove_only_changes;
  } ## end if ( $pgplines < 3 )
  if ( !@files ) {
    msg( "log,mail",
       "$main::current_incoming_short/$changes doesn't mention any files\n" );
    msg( "log", "(uploader $main::mail_addr)\n" );
    goto remove_only_changes;
  } ## end if ( !@files )

  # check for packages that shouldn't be processed
  if ( grep( $_ eq $pkgname, @conf::nonus_packages ) ) {
    msg(
         "log,mail",
         "$pkgname is a package that must be uploaded "
           . "to nonus.debian.org\n"
       );
    msg( "log,mail", "instead of target.\n" );
    msg( "log,mail",
         "Job rejected and removed all files belonging " . "to it:\n" );
    msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
    rm( $changes, @filenames );
    return;
  } ## end if ( grep( $_ eq $pkgname...

  $failure_file = $changes . ".failures";
  $retries = $last_retry = 0;
  if ( -f $failure_file ) {
    open( FAILS, "<$failure_file" )
      or die "Cannot open $main::current_incoming_short/$failure_file: $!\n";
    my $line = <FAILS>;
    close(FAILS);
    ( $retries, $last_retry ) = ( $1, $2 )
      if $line =~ /^(\d+)\s+(\d+)$/;
    push( @$keep_list, $failure_file );
  } ## end if ( -f $failure_file )

  # run PGP on the file to check the signature
  if ( !( $signator = pgp_check($changes) ) ) {
    msg(
       "log,mail",
       "$main::current_incoming_short/$changes has bad PGP/GnuPG signature!\n"
    );
    msg( "log", "(uploader $main::mail_addr)\n" );
  remove_only_changes:
    msg(
      "log,mail",
"Removing $main::current_incoming_short/$changes, but keeping its associated ",
      "files for now.\n"
    );
    rm($changes);

    # Set SGID bit on associated files, so that the test for Debian files
    # without a .changes doesn't consider them.
    foreach (@filenames) {
      my @st = stat($_);
      next if !@st;    # file may have disappeared in the meantime
      chmod +( $st[ST_MODE] |= S_ISGID ), $_;
    }
    return;
  } elsif ( $signator eq "LOCAL ERROR" ) {

    # An error has appened when starting pgp... Don't process the file,
    # but also don't delete it
    debug(
"Can't PGP/GnuPG check $main::current_incoming_short/$changes -- don't process it for now"
    );
    return;
  } ## end elsif ( $signator eq "LOCAL ERROR")

  die "Cannot stat ${main::current_incoming_short}/$changes (??): $!\n"
    if !( @changes_stats = stat($changes) );

  # Make $upload_time the maximum of all modification times of files
  # related to this .changes (and the .changes it self). This is the
  # last time something changes to these files.
  $upload_time = $changes_stats[ST_MTIME];
  for $file (@files) {
    my @stats;
    next if !( @stats = stat( $file->{"name"} ) );
    $file->{"stats"} = \@stats;
    $upload_time = $stats[ST_MTIME] if $stats[ST_MTIME] > $upload_time;
  } ## end for $file (@files)

  $do_report = ( time - $upload_time ) > $conf::problem_report_timeout;
  $problems_reported = $changes_stats[ST_MODE] & S_ISGID;

  # if any of the files is newer than the .changes' ctime (the time
  # we sent a report and set the sticky bit), send new problem reports
  if ( $problems_reported && $changes_stats[ST_CTIME] < $upload_time ) {
    $problems_reported = 0;
    chmod +( $changes_stats[ST_MODE] &= ~S_ISGID ), $changes;
    debug("upload_time>changes-ctime => resetting problems reported");
  }
  debug("do_report=$do_report problems_reported=$problems_reported");

  # now check all files for correct size and md5 sum
  for $file (@files) {
    my $filename = $file->{"name"};
    if ( !defined( $file->{"stats"} ) ) {

      # could be an upload that isn't complete yet, be quiet,
      # but don't process the file;
      msg( "log,mail", "$filename doesn't exist\n" )
        if $do_report && !$problems_reported;
      msg( "log", "$filename doesn't exist (ignored for now)\n" )
        if !$do_report;
      msg( "log", "$filename doesn't exist (already reported)\n" )
        if $problems_reported;
      ++$errs;
    } elsif ( $file->{"stats"}->[ST_SIZE] < $file->{"size"}
              && !$do_report )
    {

      # could be an upload that isn't complete yet, be quiet,
      # but don't process the file
      msg( "log", "$filename is too small (ignored for now)\n" );
      ++$errs;
    } elsif ( $file->{"stats"}->[ST_SIZE] != $file->{"size"} ) {
      msg( "log,mail", "$filename has incorrect size; deleting it\n" );
      rm($filename);
      ++$errs;
    } elsif ( md5sum($filename) ne $file->{"md5"} ) {
      msg( "log,mail",
           "$filename has incorrect md5 checksum; ",
           "deleting it\n" );
      rm($filename);
      ++$errs;
    } ## end elsif ( md5sum($filename)...
  } ## end for $file (@files)

  if ($errs) {
    if ( ( time - $upload_time ) > $conf::bad_changes_timeout ) {

      # if a .changes fails for a really long time (several days
      # or so), remove it and all associated files
      msg(
          "log,mail",
          "$main::current_incoming_short/$changes couldn't be processed for ",
          int( $conf::bad_changes_timeout / ( 60 * 60 ) ),
          " hours and is now deleted\n"
         );
      msg( "log,mail", "All files it mentions are also removed:\n" );
      msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
      rm( $changes, @filenames, $failure_file );
    } elsif ( $do_report && !$problems_reported ) {

      # otherwise, send a problem report, if not done already
      msg(
           "mail",
           "Due to the errors above, the .changes file couldn't ",
           "be processed.\n",
           "Please fix the problems for the upload to happen.\n"
         );

      # remember we already have sent a mail regarding this file
      debug("Sending problem report mail and setting SGID bit");
      my $mode = $changes_stats[ST_MODE] |= S_ISGID;
      msg( "log", "chmod failed: $!" )
        if ( chmod( $mode, $changes ) != 1 );
    } ## end elsif ( $do_report && !$problems_reported)

    # else: be quiet

    return;
  } ## end if ($errs)

  # if this upload already failed earlier, wait until the delay requirement
  # is fulfilled
  if ( $retries > 0
       && ( time - $last_retry ) <
       ( $retries == 1 ? $conf::upload_delay_1 : $conf::upload_delay_2 ) )
  {
    msg( "log", "delaying retry of upload\n" );
    return;
  } ## end if ( $retries > 0 && (...

  if ( $conf::upload_method eq "ftp" ) {
    return if !ftp_open();
  }

  # check if the job is already present on target
  # (moved to here, to avoid bothering target as long as there are errors in
  # the job)
  if ( $ls_l = is_on_target( $changes, @filenames ) ) {
    msg(
      "log,mail",
"$main::current_incoming_short/$changes is already present on target host:\n"
    );
    msg( "log,mail", "$ls_l\n" );
    msg( "mail",
         "Either you already uploaded it, or someone else ",
         "came first.\n" );
    msg( "log,mail", "Job $changes removed.\n" );
    rm( $changes, @filenames, $failure_file );
    return;
  } ## end if ( $ls_l = is_on_target...

  # clear sgid bit before upload, scp would copy it to target. We don't need
  # it anymore, we know there are no problems if we come here. Also change
  # mode of files to 644 if this should be done locally.
  $changes_stats[ST_MODE] &= ~S_ISGID;
  if ( !$conf::chmod_on_target ) {
    $changes_stats[ST_MODE] &= ~0777;
    $changes_stats[ST_MODE] |= 0644;
  }
  chmod +( $changes_stats[ST_MODE] ), $changes;

  # try uploading to target
  if ( !copy_to_target( $changes, @filenames ) ) {

    # if the upload failed, increment the retry counter and remember the
    # current time; both things are written to the .failures file. Don't
    # increment the fail counter if the error was due to incoming
    # unwritable.
    return if !$main::incoming_writable;
    if ( ++$retries >= $conf::max_upload_retries ) {
      msg( "log,mail",
           "$changes couldn't be uploaded for $retries times now.\n" );
      msg( "log,mail",
           "Giving up and removing it and its associated files:\n" );
      msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
      rm( $changes, @filenames, $failure_file );
    } else {
      $last_retry = time;
      if ( open( FAILS, ">$failure_file" ) ) {
        print FAILS "$retries $last_retry\n";
        close(FAILS);
        chmod( 0600, $failure_file )
          or die "Cannot set modes of $failure_file: $!\n";
      } ## end if ( open( FAILS, ">$failure_file"...
      push( @$keep_list, $failure_file );
      debug("now $retries failed uploads");
      msg(
           "mail",
           "The upload will be retried in ",
           print_time(
                         $retries == 1
                       ? $conf::upload_delay_1
                       : $conf::upload_delay_2
                     ),
           "\n"
         );
    } ## end else [ if ( ++$retries >= $conf::max_upload_retries)
    return;
  } ## end if ( !copy_to_target( ...

  # If the files were uploaded ok, remove them
  rm( $changes, @filenames, $failure_file );

  msg( "mail", "$changes uploaded successfully to $conf::target\n" );
  msg( "mail", "along with the files:\n  ", join( "\n  ", @filenames ),
       "\n" );
  msg( "log",
       "$changes processed successfully (uploader $main::mail_addr)\n" );

  # Check for files that have the same stem as the .changes (and weren't
  # mentioned there) and delete them. It happens often enough that people
  # upload a .orig.tar.gz where it isn't needed and also not in the
  # .changes. Explicitly deleting it (and not waiting for the
  # $stray_remove_timeout) reduces clutter in the queue dir and maybe also
  # educates uploaders :-)

  #	my $pattern = debian_file_stem( $changes );
  #	my $spattern = substr( $pattern, 0, -1 ); # strip off '*' at end
  #	my @other_files = glob($pattern);
  # filter out files that have a Debian revision at all and a different
  # revision. Those belong to a different upload.
  #	if ($changes =~ /^\Q$spattern\E-([\d.+-]+)/) {
  #		my $this_rev = $1;
  #		@other_files = grep( !/^\Q$spattern\E-([\d.+-]+)/ || $1 eq $this_rev,
  #							 @other_files);
  #}
  # Also do not remove those files if a .changes is among them. Then there
  # is probably a second upload for another version or another architecture.
  #	if (@other_files && !grep( /\.changes$/, @other_files )) {
  #		rm( @other_files );
  #		msg( "mail", "\nThe following file(s) seemed to belong to the same ".
  #					 "upload, but weren't listed\n" );
  #		msg( "mail", "in the .changes file:\n  " );
  #		msg( "mail", join( "\n  ", @other_files ), "\n" );
  #		msg( "mail", "They have been deleted.\n" );
  #		msg( "log", "Deleted files in upload not in $changes: @other_files\n" );
  #}
} ## end sub process_changes($\@)

#
# process one .commands file
#
sub process_commands($) {
  my $commands = shift;
  my ( @cmds, $cmd, $pgplines, $signator );
  local (*COMMANDS);
  my ( @files, $file, @removed, $target_delay );

  format_status_str( $main::current_changes, $commands );
  $main::dstat = "c";
  write_status_file() if $conf::statusdelay;

  msg( "log", "processing $main::current_incoming_short/$commands\n" );

  # parse the .commands file
  if ( !open( COMMANDS, "<$commands" ) ) {
    msg( "log", "Cannot open $main::current_incoming_short/$commands: $!\n" );
    return;
  }
  $pgplines        = 0;
  $main::mail_addr = "";
  @cmds            = ();
outer_loop: while (<COMMANDS>) {
    if (/^---+(BEGIN|END) PGP .*---+$/) {
      ++$pgplines;
    } elsif (/^Uploader:\s*/i) {
      chomp( $main::mail_addr = $' );
      $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
    } elsif (/^Commands:/i) {
      $_ = $';
      for ( ; ; ) {
        s/^\s*(.*)\s*$/$1/;    # delete whitespace at both ends
        if ( !/^\s*$/ ) {
          push( @cmds, $_ );
          debug("includes cmd $_");
        }
        last outer_loop if !defined( $_ = scalar(<COMMANDS>) );
        chomp;
        redo outer_loop if !/^\s/ || /^$/;
      } ## end for ( ; ; )
    } ## end elsif (/^Commands:/i)
  } ## end while (<COMMANDS>)
  close(COMMANDS);

  # some consistency checks
  if ( !$main::mail_addr || $main::mail_addr !~ /^\S+\@\S+\.\S+/ ) {
    msg( "log,mail",
"$main::current_incoming_short/$commands contains no or bad Uploader: field: "
        . "$main::mail_addr\n" );
    msg( "log,mail",
         "cannot process $main::current_incoming_short/$commands\n" );
    $main::mail_addr = "";
    goto remove;
  } ## end if ( !$main::mail_addr...
  msg( "log", "(command uploader $main::mail_addr)\n" );

  if ( $pgplines < 3 ) {
    msg(
       "log,mail",
       "$main::current_incoming_short/$commands isn't signed with PGP/GnuPG\n"
    );
    msg(
      "mail",
      "or the uploaded file is broken. Make sure to transfer in binary mode\n"
    );
    msg( "mail", "or better yet - use dcut for commands files\n" );
    goto remove;
  } ## end if ( $pgplines < 3 )

  # run PGP on the file to check the signature
  if ( !( $signator = pgp_check($commands) ) ) {
    msg(
      "log,mail",
      "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n"
    );
  remove:
    msg( "log,mail", "Removing $main::current_incoming_short/$commands\n" );
    rm($commands);
    return;
  } elsif ( $signator eq "LOCAL ERROR" ) {

    # An error has appened when starting pgp... Don't process the file,
    # but also don't delete it
    debug(
"Can't PGP/GnuPG check $main::current_incoming_short/$commands -- don't process it for now"
    );
    return;
  } ## end elsif ( $signator eq "LOCAL ERROR")
  msg( "log", "(PGP/GnuPG signature by $signator)\n" );

  # now process commands
  msg(
    "mail",
"Log of processing your commands file $main::current_incoming_short/$commands:\n\n"
  );
  foreach $cmd (@cmds) {
    my @word = split( /\s+/, $cmd );
    msg( "mail,log", "> @word\n" );
    my $selecteddelayed = -1;
    next if @word < 1;

    if ( $word[0] eq "rm" ) {
      foreach ( @word[ 1 .. $#word ] ) {
        my $origword = $_;
        if (m,^DELAYED/([0-9]+)-day/,) {
          $selecteddelayed = $1;
          s,^DELAYED/[0-9]+-day/,,;
        }
        if (m,(^|/)\*,) {
          msg("mail,log", "$_: filename component cannot start with a wildcard\n");
        } elsif ( $origword eq "--searchdirs" ) {
          $selecteddelayed = -2;
        } elsif (m,/,) {
          msg(
            "mail,log",
"$_: filename may not contain slashes except for DELAYED/#-day/ prefixes\n"
          );
        } else {

          # process wildcards but also plain names
          my (@thesefiles);
          my $pat = quotemeta($_);
          $pat =~ s/\\\*/.*/g;
          $pat =~ s/\\\?/.?/g;
          $pat =~ s/\\([][])/$1/g;

          if ( $selecteddelayed < 0 ) {    # scanning or explicitly incoming
            opendir( DIR, "." );
            push( @thesefiles, grep /^$pat$/, readdir(DIR) );
            closedir(DIR);
          }
          if ( $selecteddelayed >= 0 ) {
            my $dir = sprintf( $conf::incoming_delayed, $selecteddelayed );
            opendir( DIR, $dir );
            push( @thesefiles,
                  map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) );
            closedir(DIR);
          } elsif ( $selecteddelayed == -2 ) {
            for ( my ($adelay) = 0 ;
                  ( !@thesefiles ) && $adelay <= $conf::max_delayed ;
                  $adelay++ )
            {
              my $dir = sprintf( $conf::incoming_delayed, $adelay );
              opendir( DIR, $dir );
              push( @thesefiles,
                    map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) );
              closedir(DIR);
            } ## end for ( my ($adelay) = 0 ...
          } ## end elsif ( $selecteddelayed ...
          push( @files, @thesefiles );
          if ( !@thesefiles ) {
            msg( "mail,log", "$origword did not match anything\n" );
          }
        } ## end else [ if ( $origword eq "--searchdirs")
      } ## end foreach ( @word[ 1 .. $#word...
      if ( !@files ) {
        msg( "mail,log", "No files to delete\n" );
      } else {
        @removed = ();
        foreach $file (@files) {
          if ( !-f $file ) {
            msg( "mail,log", "$file: no such file\n" );
          } elsif ( $file =~ /$conf::keep_files/ ) {
            msg( "mail,log", "$file is protected, cannot " . "remove\n" );
          } elsif ( !unlink($file) ) {
            msg( "mail,log", "$file: rm: $!\n" );
          } else {
            $file =~ s,$conf::incoming/?,,;
            push( @removed, $file );
          }
        } ## end foreach $file (@files)
        msg( "mail,log", "Files removed: @removed\n" ) if @removed;
      } ## end else [ if ( !@files )
    } elsif ( $word[0] eq "reschedule" ) {
      if ( @word != 3 ) {
        msg( "mail,log", "Wrong number of arguments\n" );
      } elsif ( $conf::upload_method ne "copy" ) {
        msg( "mail,log", "reschedule not available\n" );
      } elsif ( $word[1] =~ m,/, || $word[1] !~ m/\.changes/ ) {
        msg(
           "mail,log",
           "$word[1]: filename may not contain slashes and must be .changes\n"
        );
      } elsif ( !( ($target_delay) = $word[2] =~ m,^([0-9]+)-day$, )
                || $target_delay > $conf::max_delayed )
      {
        msg(
          "mail,log",
"$word[2]: rescheduling target must be #-day with # between 0 and $conf::max_delayed (in particular, no '/' allowed)\n"
        );
      } elsif ( $word[1] =~ /$conf::keep_files/ ) {
        msg( "mail,log", "$word[1] is protected, cannot do stuff with it\n" );
      } else {
        my ($adelay);
        for ( $adelay = 0 ;
            $adelay <= $conf::max_delayed
            && !-f (
              sprintf( "$conf::targetdir_delayed", $adelay ) . "/$word[1]" ) ;
            $adelay++ )
        {
        } ## end for ( $adelay = 0 ; $adelay...
        if ( $adelay > $conf::max_delayed ) {
          msg( "mail,log", "$word[1] not found\n" );
        } elsif ( $adelay == $target_delay ) {
          msg( "mail,log", "$word[1] already is in $word[2]\n" );
        } else {
          my (@thesefiles);
          my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
          my ($target_dir) =
            sprintf( "$conf::targetdir_delayed", $target_delay );
          push( @thesefiles, $word[1] );
          push( @thesefiles,
                get_filelist_from_known_good_changes("$dir/$word[1]") );
          for my $afile (@thesefiles) {
            if ( $afile =~ m/\.changes$/ ) {
              utime undef, undef, ("$dir/$afile");
            }
            if ( !rename "$dir/$afile", "$target_dir/$afile" ) {
              msg( "mail,log", "rename: $!\n" );
            } else {
              msg( "mail,log", "$afile moved to $target_delay-day\n" );
            }
          } ## end for my $afile (@thesefiles)
        } ## end else [ if ( $adelay > $conf::max_delayed)
      } ## end else [ if ( @word != 3 )
    } elsif ( $word[0] eq "cancel" ) {
      if ( @word != 2 ) {
        msg( "mail,log", "Wrong number of arguments\n" );
      } elsif ( $conf::upload_method ne "copy" ) {
        msg( "mail,log", "cancel not available\n" );
      } elsif (
          $word[1] !~ m,^[a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*\.changes$, )
      {
        msg( "mail,log",
          "argument to cancel must be one .changes filename without path\n" );
      } ## end elsif ( $word[1] !~ ...
      my (@files) = ();
      for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
        my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
        if ( -f "$dir/$word[1]" ) {
          @removed = ();
          push( @files, "$word[1]" );
          push( @files,
                get_filelist_from_known_good_changes("$dir/$word[1]") );
          foreach $file (@files) {
            if ( !-f "$dir/$file" ) {
              msg( "mail,log", "$dir/$file: no such file\n" );
            } elsif ( "$dir/$file" =~ /$conf::keep_files/ ) {
              msg( "mail,log",
                   "$dir/$file is protected, cannot " . "remove\n" );
            } elsif ( !unlink("$dir/$file") ) {
              msg( "mail,log", "$dir/$file: rm: $!\n" );
            } else {
              push( @removed, $file );
            }
          } ## end foreach $file (@files)
          msg( "mail,log", "Files removed from $adelay-day: @removed\n" )
            if @removed;
        } ## end if ( -f "$dir/$word[1]")
      } ## end for ( my ($adelay) = 0 ...
      if ( !@files ) {
        msg( "mail,log", "No upload found: $word[1]\n" );
      }
    } else {
      msg( "mail,log", "unknown command $word[0]\n" );
    }
  } ## end foreach $cmd (@cmds)
  rm($commands);
  msg( "log",
       "-- End of $main::current_incoming_short/$commands processing\n" );
} ## end sub process_commands($)

sub age_delayed_queues() {
  for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
    my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
    my ($target_dir);
    if ( $adelay == 0 ) {
      $target_dir = $conf::targetdir;
    } else {
      $target_dir = sprintf( "$conf::targetdir_delayed", $adelay - 1 );
    }
    for my $achanges (<$dir/*.changes>) {
      my $mtime = ( stat($achanges) )[9];
      if ( $mtime + 24 * 60 * 60 <= time || $adelay == 0 ) {
        utime undef, undef, ($achanges);
        my @thesefiles = ( $achanges =~ m,.*/([^/]*), );
        push( @thesefiles, get_filelist_from_known_good_changes($achanges) );
        for my $afile (@thesefiles) {
          if ( !rename "$dir/$afile", "$target_dir/$afile" ) {
            msg( "log", "rename: $!\n" );
          } else {
            msg( "log", "$afile moved to $target_dir\n" );
          }
        } ## end for my $afile (@thesefiles)
      } ## end if ( $mtime + 24 * 60 ...
    } ## end for my $achanges (<$dir/*.changes>)
  } ## end for ( my ($adelay) = 0 ...
} ## end sub age_delayed_queues()

#
# check if a file is already on target
#
sub is_on_target($\@) {
  my $file     = shift;
  my $filelist = shift;
  my $msg;
  my $stat;

  if ( $conf::upload_method eq "ssh" ) {
    ( $msg, $stat ) = ssh_cmd("ls -l $file");
  } elsif ( $conf::upload_method eq "ftp" ) {
    my $err;
    ( $msg, $err ) = ftp_cmd( "dir", $file );
    if ($err) {
      $stat = 1;
      $msg  = $err;
    } elsif ( !$msg ) {
      $stat = 1;
      $msg  = "ls: no such file\n";
    } else {
      $stat = 0;
      $msg = join( "\n", @$msg );
    }
  } else {
    my @allfiles = ($file);
    push( @allfiles, @$filelist );
    $stat = 1;
    $msg  = "no such file";
    for my $afile (@allfiles) {
      if ( -f "$conf::targetdir/$afile" ) {
        $stat = 0;
        $msg  = "$afile";
      }
    } ## end for my $afile (@allfiles)
    for ( my ($adelay) = 0 ;
          $adelay <= $conf::max_delayed && $stat ;
          $adelay++ )
    {
      for my $afile (@allfiles) {
        if (
           -f ( sprintf( "$conf::targetdir_delayed", $adelay ) . "/$afile" ) )
        {
          $stat = 0;
          $msg = sprintf( "%d-day", $adelay ) . "/$afile";
        } ## end if ( -f ( sprintf( "$conf::targetdir_delayed"...
      } ## end for my $afile (@allfiles)
    } ## end for ( my ($adelay) = 0 ...
  } ## end else [ if ( $conf::upload_method...
  chomp($msg);
  debug("exit status: $stat, output was: $msg");

  return "" if $stat && $msg =~ /no such file/i;    # file not present
  msg( "log", "strange ls -l output on target:\n", $msg ), return ""
    if $stat || $@;    # some other error, but still try to upload

  # ls -l returned 0 -> file already there
  $msg =~ s/\s\s+/ /g;    # make multiple spaces into one, to save space
  return $msg;
} ## end sub is_on_target($\@)

#
# copy a list of files to target
#
sub copy_to_target(@) {
  my @files = @_;
  my ( @md5sum, @expected_files, $sum, $name, $msgs, $stat );

  $main::dstat = "u";
  write_status_file() if $conf::statusdelay;

  # copy the files
  if ( $conf::upload_method eq "ssh" ) {
    ( $msgs, $stat ) = scp_cmd(@files);
    goto err if $stat;
  } elsif ( $conf::upload_method eq "ftp" ) {
    my ( $rv, $file );
    if ( !$main::FTP_chan->cwd($main::current_targetdir) ) {
      msg( "log,mail",
           "Can't cd to $main::current_targetdir on $conf::target\n" );
      goto err;
    }
    foreach $file (@files) {
      ( $rv, $msgs ) = ftp_cmd( "put", $file );
      goto err if !$rv;
    }
  } else {
    ( $msgs, $stat ) =
      local_cmd( "$conf::cp @files $main::current_targetdir", 'NOCD' );
    goto err if $stat;
  }

  # check md5sums or sizes on target against our own
  my $have_md5sums = 1;
  if ($conf::check_md5sum) {
    if ( $conf::upload_method eq "ssh" ) {
      ( $msgs, $stat ) = ssh_cmd("md5sum @files");
      goto err if $stat;
      @md5sum = split( "\n", $msgs );
    } elsif ( $conf::upload_method eq "ftp" ) {
      my ( $rv, $err, $file );
      foreach $file (@files) {
        ( $rv, $err ) = ftp_cmd( "quot", "site", "md5sum", $file );
        if ($err) {
          next if ftp_code() == 550;    # file not found
          if ( ftp_code() == 500 ) {    # unimplemented
            $have_md5sums = 0;
            goto get_sizes_instead;
          }
          $msgs = $err;
          goto err;
        } ## end if ($err)
        chomp( my $t = ftp_response() );
        push( @md5sum, $t );
      } ## end foreach $file (@files)
      if ( !$have_md5sums ) {
      get_sizes_instead:
        foreach $file (@files) {
          ( $rv, $err ) = ftp_cmd( "size", $file );
          if ($err) {
            next if ftp_code() == 550;    # file not found
            $msgs = $err;
            goto err;
          }
          push( @md5sum, "$rv $file" );
        } ## end foreach $file (@files)
      } ## end if ( !$have_md5sums )
    } else {
      ( $msgs, $stat ) = local_cmd("$conf::md5sum @files");
      goto err if $stat;
      @md5sum = split( "\n", $msgs );
    }

    @expected_files = @files;
    foreach (@md5sum) {
      chomp;
      ( $sum, $name ) = split;
      next if !grep { $_ eq $name } @files;    # a file we didn't upload??
      next if $sum eq "md5sum:";               # looks like an error message
      if (    ( $have_md5sums && $sum ne md5sum($name) )
           || ( !$have_md5sums && $sum != ( -s $name ) ) )
      {
        msg(
             "log,mail",
             "Upload of $name to $conf::target failed ",
             "(" . ( $have_md5sums ? "md5sum" : "size" ) . " mismatch)\n"
           );
        goto err;
      } ## end if ( ( $have_md5sums &&...

      # seen that file, remove it from expect list
      @expected_files = map { $_ eq $name ? () : $_ } @expected_files;
    } ## end foreach (@md5sum)
    if (@expected_files) {
      msg( "log,mail", "Failed to upload the files\n" );
      msg( "log,mail", "  ", join( ", ", @expected_files ), "\n" );
      msg( "log,mail", "(Not present on target after upload)\n" );
      goto err;
    } ## end if (@expected_files)
  } ## end if ($conf::check_md5sum)

  if ($conf::chmod_on_target) {

    # change file's mode explicitly to 644 on target
    if ( $conf::upload_method eq "ssh" ) {
      ( $msgs, $stat ) = ssh_cmd("chmod 644 @files");
      goto err if $stat;
    } elsif ( $conf::upload_method eq "ftp" ) {
      my ( $rv, $file );
      foreach $file (@files) {
        ( $rv, $msgs ) = ftp_cmd( "quot", "site", "chmod", "644", $file );
        msg( "log", "Can't chmod $file on target:\n$msgs" )
          if $msgs;
        goto err if !$rv;
      } ## end foreach $file (@files)
    } else {
      ( $msgs, $stat ) = local_cmd("$conf::chmod 644 @files");
      goto err if $stat;
    }
  } ## end if ($conf::chmod_on_target)

  $main::dstat = "c";
  write_status_file() if $conf::statusdelay;
  return 1;

err:
  msg( "log,mail",
       "Upload to $conf::target failed",
       $? ? ", last exit status " . sprintf( "%s", $? >> 8 ) : "", "\n" );
  msg( "log,mail", "Error messages:\n", $msgs )
    if $msgs;

  # If "permission denied" was among the errors, test if the incoming is
  # writable at all.
  if ( $msgs =~ /(permission denied|read-?only file)/i ) {
    if ( !check_incoming_writable() ) {
      msg( "log,mail", "(The incoming directory seems to be ",
           "unwritable.)\n" );
    }
  } ## end if ( $msgs =~ /(permission denied|read-?only file)/i)

  # remove bad files or an incomplete upload on target
  if ( $conf::upload_method eq "ssh" ) {
    ssh_cmd("rm -f @files");
  } elsif ( $conf::upload_method eq "ftp" ) {
    my $file;
    foreach $file (@files) {
      my ( $rv, $err );
      ( $rv, $err ) = ftp_cmd( "delete", $file );
      msg( "log", "Can't delete $file on target:\n$err" )
        if $err;
    } ## end foreach $file (@files)
  } else {
    my @tfiles = map { "$main::current_targetdir/$_" } @files;
    debug("executing unlink(@tfiles)");
    rm(@tfiles);
  }
  $main::dstat = "c";
  write_status_file() if $conf::statusdelay;
  return 0;
} ## end sub copy_to_target(@)

#
# check if a file is correctly signed with PGP
#
sub pgp_check($) {
  my $file   = shift;
  my $output = "";
  my $signator;
  my $found = 0;
  my $stat;
  local (*PIPE);

  $stat = 1;
  if ( -x $conf::gpg ) {
    debug(   "executing $conf::gpg --no-options --batch "
           . "--no-default-keyring --always-trust "
           . "--keyring "
           . join( " --keyring ", @conf::keyrings )
           . " --verify '$file'" );
    if (
         !open( PIPE,
                    "$conf::gpg --no-options --batch "
                  . "--no-default-keyring --always-trust "
                  . "--keyring "
                  . join( " --keyring ", @conf::keyrings )
                  . " --verify '$file'"
                  . " 2>&1 |"
              )
       )
    {
      msg( "log", "Can't open pipe to $conf::gpg: $!\n" );
      return "LOCAL ERROR";
    } ## end if ( !open( PIPE, "$conf::gpg --no-options --batch "...
    $output .= $_ while (<PIPE>);
    close(PIPE);
    $stat = $?;
  } ## end if ( -x $conf::gpg )

  if ($stat) {
    msg( "log,mail", "GnuPG signature check failed on $file\n" );
    msg( "mail",     $output );
    msg( "log,mail", "(Exit status ", $stat >> 8, ")\n" );
    return "";
  } ## end if ($stat)

  $output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im;
  ( $signator = $3 ) ||= "unknown signator";
  if ($conf::debug) {
    debug("GnuPG signature ok (by $signator)");
  }
  return $signator;
} ## end sub pgp_check($)

# ---------------------------------------------------------------------------
#							  the status daemon
# ---------------------------------------------------------------------------

#
# fork a subprocess that watches the 'status' FIFO
#
# that process blocks until someone opens the FIFO, then sends a
# signal (SIGUSR1) to the main process, expects
#
sub fork_statusd() {
  my $statusd_pid;
  my $main_pid = $$;
  my $errs;
  local (*STATFIFO);

  $statusd_pid = open( STATUSD, "|-" );
  die "cannot fork: $!\n" if !defined($statusd_pid);

  # parent just returns
  if ($statusd_pid) {
    msg( "log", "forked status daemon (pid $statusd_pid)\n" );
    return $statusd_pid;
  }

  # child: the status FIFO daemon

  # ignore SIGPIPE here, in case some closes the FIFO without completely
  # reading it
  $SIG{"PIPE"} = "IGNORE";

  # also ignore SIGCLD, we don't want to inherit the restart-statusd handler
  # from our parent
  $SIG{"CHLD"} = "DEFAULT";

  rm($conf::statusfile);
  $errs = `$conf::mkfifo $conf::statusfile`;
  die "$main::progname: cannot create named pipe $conf::statusfile: $errs"
    if $?;
  chmod( 0644, $conf::statusfile )
    or die "Cannot set modes of $conf::statusfile: $!\n";

  # close log file, so that log rotating works
  close(LOG);
  close(STDOUT);
  close(STDERR);

  while (1) {
    my ( $status, $mup, $incw, $ds, $next_run, $last_ping, $currch, $l );

    # open the FIFO for writing; this blocks until someone (probably ftpd)
    # opens it for reading
    open( STATFIFO, ">$conf::statusfile" )
      or die "Cannot open $conf::statusfile\n";
    select(STATFIFO);

    # tell main daemon to send us status infos
    kill( $main::signo{"USR1"}, $main_pid );

    # get the infos from stdin; must loop until enough bytes received!
    my $expect_len = 3 + 2 * STATNUM_LEN + STATSTR_LEN;
    for ( $status = "" ; ( $l = length($status) ) < $expect_len ; ) {
      sysread( STDIN, $status, $expect_len - $l, $l );
    }

    # disassemble the status byte stream
    my $pos = 0;
    foreach (
              [ mup       => 1 ],
              [ incw      => 1 ],
              [ ds        => 1 ],
              [ next_run  => STATNUM_LEN ],
              [ last_ping => STATNUM_LEN ],
              [ currch    => STATSTR_LEN ]
            )
    {
      eval "\$$_->[0] = substr( \$status, $pos, $_->[1] );";
      $pos += $_->[1];
    } ## end foreach ( [ mup => 1 ], [ incw...
    $currch =~ s/\n+//g;

    print_status( $mup, $incw, $ds, $next_run, $last_ping, $currch );
    close(STATFIFO);

    # This sleep is necessary so that we can't reopen the FIFO
    # immediately, in case the reader hasn't closed it yet if we get to
    # the open again. Is there a better solution for this??
    sleep 1;
  } ## end while (1)
} ## end sub fork_statusd()

#
# update the status file, in case we use a plain file and not a FIFO
#
sub write_status_file() {

  return if !$conf::statusfile;

  open( STATFILE, ">$conf::statusfile" )
    or ( msg( "log", "Could not open $conf::statusfile: $!\n" ), return );
  my $oldsel = select(STATFILE);

  print_status(
                $main::target_up,      $main::incoming_writable,
                $main::dstat,          $main::next_run,
                $main::last_ping_time, $main::current_changes
              );

  select($oldsel);
  close(STATFILE);
} ## end sub write_status_file()

sub print_status($$$$$$) {
  my $mup       = shift;
  my $incw      = shift;
  my $ds        = shift;
  my $next_run  = shift;
  my $last_ping = shift;
  my $currch    = shift;
  my $approx;
  my $version;

  ( $version = 'Release: 0.9 $Revision: 1.51 $' ) =~ s/\$ ?//g;
  print "debianqueued $version\n";

  $approx = $conf::statusdelay ? "approx. " : "";

  if ( $mup eq "0" ) {
    print "$conf::target is down, queue pausing\n";
    return;
  } elsif ( $conf::upload_method ne "copy" ) {
    print "$conf::target seems to be up, last ping $approx",
      print_time( time - $last_ping ), " ago\n";
  }

  if ( $incw eq "0" ) {
    print "The incoming directory is not writable, queue pausing\n";
    return;
  }

  if ( $ds eq "i" ) {
    print "Next queue check in $approx", print_time( $next_run - time ), "\n";
    return;
  } elsif ( $ds eq "c" ) {
    print "Checking queue directory\n";
  } elsif ( $ds eq "u" ) {
    print "Uploading to $conf::target\n";
  } else {
    print "Bad status data from daemon: \"$mup$incw$ds\"\n";
    return;
  }

  print "Current job is $currch\n" if $currch;
} ## end sub print_status($$$$$$)

#
# format a number for sending to statusd (fixed length STATNUM_LEN)
#
sub format_status_num(\$$) {
  my $varref = shift;
  my $num    = shift;

  $$varref = sprintf "%" . STATNUM_LEN . "d", $num;
} ## end sub format_status_num(\$$)

#
# format a string for sending to statusd (fixed length STATSTR_LEN)
#
sub format_status_str(\$$) {
  my $varref = shift;
  my $str    = shift;

  $$varref = substr( $str, 0, STATSTR_LEN );
  $$varref .= "\n" x ( STATSTR_LEN - length($$varref) );
} ## end sub format_status_str(\$$)

#
# send a status string to the status daemon
#
# Avoid all operations that could call malloc() here! Most libc
# implementations aren't reentrant, so we may not call it from a
# signal handler. So use only already-defined variables.
#
sub send_status() {
  local $! = 0;    # preserve errno

  # re-setup handler, in case we have broken SysV signals
  $SIG{"USR1"} = \&send_status;

  syswrite( STATUSD, $main::target_up,         1 );
  syswrite( STATUSD, $main::incoming_writable, 1 );
  syswrite( STATUSD, $main::dstat,             1 );
  syswrite( STATUSD, $main::next_run,          STATNUM_LEN );
  syswrite( STATUSD, $main::last_ping_time,    STATNUM_LEN );
  syswrite( STATUSD, $main::current_changes,   STATSTR_LEN );
} ## end sub send_status()

# ---------------------------------------------------------------------------
#							    FTP functions
# ---------------------------------------------------------------------------

#
# open FTP connection to target host if not already open
#
sub ftp_open() {

  if ($main::FTP_chan) {

    # is already open, but might have timed out; test with a cwd
    return $main::FTP_chan
      if $main::FTP_chan->cwd($main::current_targetdir);

    # cwd didn't work, channel is closed, try to reopen it
    $main::FTP_chan = undef;
  } ## end if ($main::FTP_chan)

  if (
       !(
          $main::FTP_chan =
          Net::FTP->new(
                         $conf::target,
                         Debug   => $conf::ftpdebug,
                         Timeout => $conf::ftptimeout,
                         Passive => 1,
                       )
        )
     )
  {
    msg( "log,mail", "Cannot open FTP server $conf::target\n" );
    goto err;
  } ## end if ( !( $main::FTP_chan...
  if ( !$main::FTP_chan->login() ) {
    msg( "log,mail", "Anonymous login on FTP server $conf::target failed\n" );
    goto err;
  }
  if ( !$main::FTP_chan->binary() ) {
    msg( "log,mail", "Can't set binary FTP mode on $conf::target\n" );
    goto err;
  }
  if ( !$main::FTP_chan->cwd($main::current_targetdir) ) {
    msg( "log,mail",
         "Can't cd to $main::current_targetdir on $conf::target\n" );
    goto err;
  }
  debug("opened FTP channel to $conf::target");
  return 1;

err:
  $main::FTP_chan = undef;
  return 0;
} ## end sub ftp_open()

sub ftp_cmd($@) {
  my $cmd = shift;
  my ( $rv, $err );
  my $direct_resp_cmd = ( $cmd eq "quot" );

  debug( "executing FTP::$cmd(" . join( ", ", @_ ) . ")" );
  $SIG{"ALRM"} = sub { die "timeout in FTP::$cmd\n" };
  alarm($conf::remote_timeout);
  eval { $rv = $main::FTP_chan->$cmd(@_); };
  alarm(0);
  $err = "";
  $rv = ( ftp_code() =~ /^2/ ) ? 1 : 0 if $direct_resp_cmd;
  if ($@) {
    $err = $@;
    undef $rv;
  } elsif ( !$rv ) {
    $err = ftp_response();
  }
  return ( $rv, $err );
} ## end sub ftp_cmd($@)

sub ftp_close() {
  if ($main::FTP_chan) {
    $main::FTP_chan->quit();
    $main::FTP_chan = undef;
  }
  return 1;
} ## end sub ftp_close()

sub ftp_response() {
  return join( '', @{ ${*$main::FTP_chan}{'net_cmd_resp'} } );
}

sub ftp_code() {
  return ${*$main::FTP_chan}{'net_cmd_code'};
}

sub ftp_error() {
  my $code = ftp_code();
  return ( $code =~ /^[45]/ ) ? 1 : 0;
}

# ---------------------------------------------------------------------------
#							  utility functions
# ---------------------------------------------------------------------------

sub ssh_cmd($) {
  my $cmd = shift;
  my ( $msg, $stat );

  my $ecmd = "$conf::ssh $conf::ssh_options $conf::target "
    . "-l $conf::targetlogin \'cd $main::current_targetdir; $cmd\'";
  debug("executing $ecmd");
  $SIG{"ALRM"} = sub { die "timeout in ssh command\n" };
  alarm($conf::remote_timeout);
  eval { $msg = `$ecmd 2>&1`; };
  alarm(0);
  if ($@) {
    $msg  = $@;
    $stat = 1;
  } else {
    $stat = $?;
  }
  return ( $msg, $stat );
} ## end sub ssh_cmd($)

sub scp_cmd(@) {
  my ( $msg, $stat );

  my $ecmd = "$conf::scp $conf::ssh_options @_ "
    . "$conf::targetlogin\@$conf::target:$main::current_targetdir";
  debug("executing $ecmd");
  $SIG{"ALRM"} = sub { die "timeout in scp\n" };
  alarm($conf::remote_timeout);
  eval { $msg = `$ecmd 2>&1`; };
  alarm(0);
  if ($@) {
    $msg  = $@;
    $stat = 1;
  } else {
    $stat = $?;
  }
  return ( $msg, $stat );
} ## end sub scp_cmd(@)

sub local_cmd($;$) {
  my $cmd  = shift;
  my $nocd = shift;
  my ( $msg, $stat );

  my $ecmd = ( $nocd ? "" : "cd $main::current_targetdir; " ) . $cmd;
  debug("executing $ecmd");
  $msg  = `($ecmd) 2>&1`;
  $stat = $?;
  return ( $msg, $stat );

} ## end sub local_cmd($;$)

#
# check if target is alive (code stolen from Net::Ping.pm)
#
sub check_alive(;$) {
  my $timeout = shift;
  my ( $saddr, $ret, $target_ip );
  local (*PINGSOCK);

  if ( $conf::upload_method eq "copy" ) {
    format_status_num( $main::last_ping_time, time );
    $main::target_up = 1;
    return;
  }

  $timeout ||= 30;

  if ( !( $target_ip = ( gethostbyname($conf::target) )[4] ) ) {
    msg( "log", "Cannot get IP address of $conf::target\n" );
    $ret = 0;
    goto out;
  }
  $saddr = pack( 'S n a4 x8', AF_INET, $main::echo_port, $target_ip );
  $SIG{'ALRM'} = sub { die };
  alarm($timeout);

  $ret = $main::tcp_proto;    # avoid warnings about unused variable
  $ret = 0;
  eval <<'EOM' ;
    return unless socket( PINGSOCK, PF_INET, SOCK_STREAM, $main::tcp_proto );
    return unless connect( PINGSOCK, $saddr );
    $ret = 1;
EOM
  alarm(0);
  close(PINGSOCK);
  msg( "log", "pinging $conf::target: " . ( $ret ? "ok" : "down" ) . "\n" );
out:
  $main::target_up = $ret ? "1" : "0";
  format_status_num( $main::last_ping_time, time );
  write_status_file() if $conf::statusdelay;
} ## end sub check_alive(;$)

#
# check if incoming dir on target is writable
#
sub check_incoming_writable() {
  my $testfile = ".debianqueued-testfile";
  my ( $msg, $stat );

  if ( $conf::upload_method eq "ssh" ) {
    ( $msg, $stat ) =
      ssh_cmd( "rm -f $testfile; touch $testfile; " . "rm -f $testfile" );
  } elsif ( $conf::upload_method eq "ftp" ) {
    my $file = "junk-for-writable-test-" . format_time();
    $file =~ s/[ :.]/-/g;
    local (*F);
    open( F, ">$file" );
    close(F);
    my $rv;
    ( $rv, $msg ) = ftp_cmd( "put", $file );
    $stat = 0;
    $msg = "" if !defined $msg;
    unlink $file;
    ftp_cmd( "delete", $file );
  } elsif ( $conf::upload_method eq "copy" ) {
    ( $msg, $stat ) =
      local_cmd( "rm -f $testfile; touch $testfile; " . "rm -f $testfile" );
  }
  chomp($msg);
  debug("exit status: $stat, output was: $msg");

  if ( !$stat ) {

    # change incoming_writable only if ssh didn't return an error
    $main::incoming_writable =
      ( $msg =~ /(permission denied|read-?only file|cannot create)/i )
      ? "0"
      : "1";
  } else {
    debug("local error, keeping old status");
  }
  debug("incoming_writable = $main::incoming_writable");
  write_status_file() if $conf::statusdelay;
  return $main::incoming_writable;
} ## end sub check_incoming_writable()

#
# remove a list of files, log failing ones
#
sub rm(@) {
  my $done = 0;

  foreach (@_) {
    ( unlink $_ and ++$done )
      or $! == ENOENT
      or msg( "log", "Could not delete $_: $!\n" );
  }
  return $done;
} ## end sub rm(@)

#
# get md5 checksum of a file
#
sub md5sum($) {
  my $file = shift;
  my $line;

  chomp( $line = `$conf::md5sum $file` );
  debug( "md5sum($file): ",
           $? ? "exit status $?"
         : $line =~ /^(\S+)/ ? $1
         :                     "match failed" );
  return $? ? "" : $line =~ /^(\S+)/ ? $1 : "";
} ## end sub md5sum($)

#
# check if a file probably belongs to a Debian upload
#
sub is_debian_file($) {
  my $file = shift;
  return $file =~ /\.(deb|dsc|(diff|tar)\.gz)$/
    && $file !~ /\.orig\.tar\.gz/;
}

#
# try to extract maintainer email address from some a non-.changes file
# return "" if not possible
#
sub get_maintainer($) {
  my $file       = shift;
  my $maintainer = "";
  local (*F);

  if ( $file =~ /\.diff\.gz$/ ) {

    # parse a diff
    open( F, "$conf::gzip -dc '$file' 2>/dev/null |" ) or return "";
    while (<F>) {

      # look for header line of a file */debian/control
      last if m,^\+\+\+\s+[^/]+/debian/control(\s+|$),;
    }
    while (<F>) {
      last if /^---/;   # end of control file patch, no Maintainer: found
                        # inside control file patch look for Maintainer: field
      $maintainer = $1, last if /^\+Maintainer:\s*(.*)$/i;
    }
    while (<F>) { }     # read to end of file to avoid broken pipe
    close(F) or return "";
  } elsif ( $file =~ /\.(deb|dsc|tar\.gz)$/ ) {
    if ( $file =~ /\.deb$/ && $conf::ar ) {

      # extract control.tar.gz from .deb with ar, then let tar extract
      # the control file itself
      open( F,
                "($conf::ar p '$file' control.tar.gz | "
              . "$conf::tar -xOf - "
              . "--use-compress-program $conf::gzip "
              . "control) 2>/dev/null |"
          ) or return "";
    } elsif ( $file =~ /\.dsc$/ ) {

      # just do a plain grep
      debug("get_maint: .dsc, no cmd");
      open( F, "<$file" ) or return "";
    } elsif ( $file =~ /\.tar\.gz$/ ) {

      # let tar extract a file */debian/control
      open( F,
                "$conf::tar -xOf '$file' "
              . "--use-compress-program $conf::gzip "
              . "\\*/debian/control 2>&1 |"
          ) or return "";
    } else {
      return "";
    }
    while (<F>) {
      $maintainer = $1, last if /^Maintainer:\s*(.*)$/i;
    }
    close(F) or return "";
  } ## end elsif ( $file =~ /\.(deb|dsc|tar\.gz)$/)

  return $maintainer;
} ## end sub get_maintainer($)

#
# return a pattern that matches all files that probably belong to one job
#
sub debian_file_stem($) {
  my $file = shift;
  my ( $pkg, $version );

  # strip file suffix
  $file =~ s,\.(deb|dsc|changes|(orig\.)?tar\.gz|diff\.gz)$,,;

  # if not is *_* (name_version), can't derive a stem and return just
  # the file's name
  return $file if !( $file =~ /^([^_]+)_([^_]+)/ );
  ( $pkg, $version ) = ( $1, $2 );

  # strip Debian revision from version
  $version =~ s/^(.*)-[\d.+-]+$/$1/;

  return "${pkg}_${version}*";
} ## end sub debian_file_stem($)

#
# output a messages to several destinations
#
# first arg is a comma-separated list of destinations; valid are "log"
# and "mail"; rest is stuff to be printed, just as with print
#
sub msg($@) {
  my @dest = split( ',', shift );

  if ( grep /log/, @dest ) {
    my $now = format_time();
    print LOG "$now ", @_;
  }

  if ( grep /mail/, @dest ) {
    $main::mail_text .= join( '', @_ );
  }
} ## end sub msg($@)

#
# print a debug messages, if $debug is true
#
sub debug(@) {
  return if !$conf::debug;
  my $now = format_time();
  print LOG "$now DEBUG ", @_, "\n";
}

#
# intialize the "mail" destination of msg() (this clears text,
# address, subject, ...)
#
sub init_mail(;$) {
  my $file = shift;

  $main::mail_addr    = "";
  $main::mail_text    = "";
  %main::packages     = ();
  $main::mail_subject = $file ? "Processing of $file" : "";
} ## end sub init_mail(;$)

#
# finalize mail to be sent from msg(): check if something present, and
# then send out
#
sub finish_mail() {

  debug("No mail for $main::mail_addr")
    if $main::mail_addr && !$main::mail_text;
  return unless $main::mail_addr && $main::mail_text;

  if ( !send_mail( $main::mail_addr, $main::mail_subject, $main::mail_text ) )
  {

    # store this mail in memory so it isn't lost if executing sendmail
    # failed.
    push(
          @main::stored_mails,
          {
            addr    => $main::mail_addr,
            subject => $main::mail_subject,
            text    => $main::mail_text
          }
        );
  } ## end if ( !send_mail( $main::mail_addr...
  init_mail();

  # try to send out stored mails
  my $mailref;
  while ( $mailref = shift(@main::stored_mails) ) {
    if (
         !send_mail( $mailref->{'addr'}, $mailref->{'subject'},
                     $mailref->{'text'} )
       )
    {
      unshift( @main::stored_mails, $mailref );
      last;
    } ## end if ( !send_mail( $mailref...
  } ## end while ( $mailref = shift(...
} ## end sub finish_mail()

#
# send one mail
#
sub send_mail($$$) {
  my $addr    = shift;
  my $subject = shift;
  my $text    = shift;

  my $package =
    keys %main::packages ? join( ' ', keys %main::packages ) : "";

  use Email::Send;

  unless ( defined($Email::Send::Sendmail::SENDMAIL) ) {
    $Email::Send::Sendmail::SENDMAIL = $conf::mail;
  }

  my $date = sprintf "%s",
    strftime( "%a, %d %b %Y %T %z", ( localtime(time) ) );
  my $message = <<__MESSAGE__;
To: $addr
From: Archive Administrator <dak\@ftp-master.debian.org>
Subject: $subject
Date: $date
X-Debian: DAK
__MESSAGE__

  if ( length $package ) {
    $message .= "X-Debian-Package: $package\n";
  }

  $message .= "\n$text";
  $message .= "\nGreetings,\n\n\tYour Debian queue daemon (running on host $main::hostname)\n";

  my $mail = Email::Send->new;
  for (qw[Sendmail SMTP]) {
    $mail->mailer($_) and last if $mail->mailer_available($_);
  }

  my $ret = $mail->send($message);
  if ( $ret && $ret !~ /Message sent|success/ ) {
    return 0;
  }

  return 1;
} ## end sub send_mail($$$)

#
# try to find a mail address for a name in the keyrings
#
sub try_to_get_mail_addr($$) {
  my $name    = shift;
  my $listref = shift;

  @$listref = ();
  open( F,
            "$conf::gpg --no-options --batch --no-default-keyring "
          . "--always-trust --keyring "
          . join( " --keyring ", @conf::keyrings )
          . " --list-keys |"
      ) or return "";
  while (<F>) {
    if ( /^pub / && / $name / ) {
      /<([^>]*)>/;
      push( @$listref, $1 );
    }
  } ## end while (<F>)
  close(F);

  return ( @$listref >= 1 ) ? $listref->[0] : "";
} ## end sub try_to_get_mail_addr($$)

#
# return current time as string
#
sub format_time() {
  my $t;

  # omit weekday and year for brevity
  ( $t = localtime ) =~ /^\w+\s(.*)\s\d+$/;
  return $1;
} ## end sub format_time()

sub print_time($) {
  my $secs = shift;
  my $hours = int( $secs / ( 60 * 60 ) );

  $secs -= $hours * 60 * 60;
  return sprintf "%d:%02d:%02d", $hours, int( $secs / 60 ), $secs % 60;
} ## end sub print_time($)

#
# block some signals during queue processing
#
# This is just to avoid data inconsistency or uploads being aborted in the
# middle. Only "soft" signals are blocked, i.e. SIGINT and SIGTERM, try harder
# ones if you really want to kill the daemon at once.
#
sub block_signals() {
  POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset );
}

sub unblock_signals() {
  POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset );
}

#
# process SIGHUP: close log file and reopen it (for logfile cycling)
#
sub close_log($) {
  close(LOG);
  close(STDOUT);
  close(STDERR);

  open( LOG, ">>$conf::logfile" )
    or die "Cannot open my logfile $conf::logfile: $!\n";
  chmod( 0644, $conf::logfile )
    or msg( "log", "Cannot set modes of $conf::logfile: $!\n" );
  select( ( select(LOG), $| = 1 )[0] );

  open( STDOUT, ">&LOG" )
    or msg( "log",
      "$main::progname: Can't redirect stdout to " . "$conf::logfile: $!\n" );
  open( STDERR, ">&LOG" )
    or msg( "log",
      "$main::progname: Can't redirect stderr to " . "$conf::logfile: $!\n" );
  msg( "log", "Restart after SIGHUP\n" );
} ## end sub close_log($)

#
# process SIGCHLD: check if it was our statusd process
#
sub kid_died($) {
  my $pid;

  # reap statusd, so that it's no zombie when we try to kill(0) it
  waitpid( $main::statusd_pid, WNOHANG );

  # Uncomment the following line if your Perl uses unreliable System V signal
  # (i.e. if handlers reset to default if the signal is delivered).
  # (Unfortunately, the re-setup can't be done in any case, since on some
  # systems this will cause the SIGCHLD to be delivered again if there are
  # still unreaped children :-(( )

  #	 $SIG{"CHLD"} = \&kid_died; # resetup handler for SysV
} ## end sub kid_died($)

sub restart_statusd() {

  # restart statusd if it died
  if ( !kill( 0, $main::statusd_pid ) ) {
    close(STATUSD);    # close out pipe end
    $main::statusd_pid = fork_statusd();
  }
} ## end sub restart_statusd()

#
# process a fatal signal: cleanup and exit
#
sub fatal_signal($) {
  my $signame = shift;
  my $sig;

  # avoid recursions of fatal_signal in case of BSD signals
  foreach $sig (qw( ILL ABRT BUS FPE SEGV PIPE )) {
    $SIG{$sig} = "DEFAULT";
  }

  if ( $$ == $main::maind_pid ) {

    # only the main daemon should do this
    kill( $main::signo{"TERM"}, $main::statusd_pid )
      if defined $main::statusd_pid;
    unlink( $conf::statusfile, $conf::pidfile );
  } ## end if ( $$ == $main::maind_pid)
  msg( "log", "Caught SIG$signame -- exiting (pid $$)\n" );
  exit 1;
} ## end sub fatal_signal($)

# Local Variables:
#  tab-width: 4
#  fill-column: 78
# End: