tools/debianqueued-0.9/debianqueued

   1 #!/usr/bin/perl -w
   2 #
   3 # debianqueued -- daemon for managing Debian upload queues
   4 #
   5 # Copyright (C) 1997 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>
   6 # Copyright (C) 2001-2007 Ryan Murray <rmurray@debian.org>
   7 #
   8 # This program is free software.  You can redistribute it and/or
   9 # modify it under the terms of the GNU General Public License as
  10 # published by the Free Software Foundation: either version 2 or
  11 # (at your option) any later version.
  12 # This program comes with ABSOLUTELY NO WARRANTY!
  13 #
  14 # $Id: debianqueued,v 1.51 1999/07/08 09:43:21 ftplinux Exp $
  15 #
  16 # $Log: debianqueued,v $
  17 # Revision 1.51  1999/07/08 09:43:21  ftplinux
  18 # Bumped release number to 0.9
  19 #
  20 # Revision 1.50  1999/07/07 16:17:30  ftplinux
  21 # Signatures can now also be created by GnuPG; in pgp_check, also try
  22 # gpg for checking.
  23 # In several messages, also mention GnuPG.
  24 #
  25 # Revision 1.49  1999/07/07 16:14:43  ftplinux
  26 # Implemented new upload methods "copy" and "ftp" as alternatives to "ssh".
  27 # Replaced "master" in many function and variable names by "target".
  28 # New functions ssh_cmd, ftp_cmd, and local_cmd for more abstraction and
  29 # better readable code.
  30 #
  31 # Revision 1.48  1998/12/08 13:09:39  ftplinux
  32 # At the end of process_changes, do not remove the @other_files with the same
  33 # stem if a .changes file is in that list; then there is probably another
  34 # upload for a different version or another architecture.
  35 #
  36 # Revision 1.47  1998/05/14 14:21:44  ftplinux
  37 # Bumped release number to 0.8
  38 #
  39 # Revision 1.46  1998/05/14 14:17:00  ftplinux
  40 # When --after a successfull upload-- deleting files for the same job, check
  41 # for equal revision number on files that have one. It has happened that the
  42 # daemon deleted files that belonged to another job with different revision.
  43 #
  44 # Revision 1.45  1998/04/23 11:05:47  ftplinux
  45 # Implemented $conf::chmod_on_master. If 0, new part to change mode locally in
  46 # process_changes.
  47 #
  48 # Revision 1.44  1998/04/21 08:44:44  ftplinux
  49 # Don't use return value of debian_file_stem as regexp, it's a shell pattern.
  50 #
  51 # Revision 1.43  1998/04/21 08:22:21  ftplinux
  52 # Also recogize "read-only filesystem" as error message so it triggers assuming
  53 # that incoming is unwritable.
  54 # Don't increment failure count after an upload try that did clear
  55 # $incoming_writable.
  56 # Fill in forgotten pattern for mail addr in process_commands.
  57 #
  58 # Revision 1.42  1998/03/31 13:27:32  ftplinux
  59 # In fatal_signal, kill status daemon only if it has been started (otherwise
  60 # warning about uninitialized variable).
  61 # Change mode of files uploaded to master explicitly to 644 there, scp copies the
  62 # permissions in the queue.
  63 #
  64 # Revision 1.41  1998/03/31 09:06:00  ftplinux
  65 # Implemented handling of improper mail addresses in Maintainer: field.
  66 #
  67 # Revision 1.40  1998/03/24 13:17:33  ftplinux
  68 # Added new check if incoming dir on master is writable. This check is triggered
  69 # if an upload returns "permission denied" errors. If the dir is unwritable, the
  70 # queue is holded (no upload tries) until it's writable again.
  71 #
  72 # Revision 1.39  1998/03/23 14:05:14  ftplinux
  73 # Bumped release number to 0.7
  74 #
  75 # Revision 1.38  1998/03/23 14:03:55  ftplinux
  76 # In an upload failure message, say explicitly that the job will be
  77 # retried, to avoid confusion of users.
  78 # $failure_file was put on @keep_list only for first retry.
  79 # If the daemon removes a .changes, set SGID bit on all files associated
  80 # with it, so that the test for Debian files without a .changes doesn't
  81 # find them.
  82 # Don't send reports for files without a .changes if the files look like
  83 # a recompilation for another architecture.
  84 # Also don't send such a report if the list of files with the same stem
  85 # contains a .changes.
  86 # Set @keep_list earlier, before PGP and non-US checks.
  87 # Fix recognition of -k argument.
  88 #
  89 # Revision 1.37  1998/02/17 12:29:58  ftplinux
  90 # Removed @conf::test_binaries used only once warning
  91 # Try to kill old daemon for 20secs instead of 10
  92 #
  93 # Revision 1.36  1998/02/17 10:53:47  ftplinux
  94 # Added test for binaries on maybe-slow NFS filesystems (@conf::test_binaries)
  95 #
  96 # Revision 1.35  1997/12/16 13:19:28  ftplinux
  97 # Bumped release number to 0.6
  98 #
  99 # Revision 1.34  1997/12/09 13:51:24  ftplinux
 100 # Implemented rejecting of nonus packages (new config var @nonus_packages)
 101 #
 102 # Revision 1.33  1997/11/25 10:40:53  ftplinux
 103 # In check_alive, loop up the IP address everytime, since it can change
 104 # while the daemon is running.
 105 # process_changes: Check presence of .changes on master at a later
 106 # point, to avoid bothering master as long as there are errors in a
 107 # .changes.
 108 # Don't view .orig.tar.gz files as is_debian_file, to avoid that they're
 109 # picked for extracting the maintainer address in the
 110 # job-without-changes processing.
 111 # END statement: Fix swapped arguments to kill
 112 # Program startup: Implemented -r and -k arguments.
 113 #
 114 # Revision 1.32  1997/11/20 15:18:47  ftplinux
 115 # Bumped release number to 0.5
 116 #
 117 # Revision 1.31  1997/11/11 13:37:52  ftplinux
 118 # Replaced <./$pattern> contruct be cleaner glob() call
 119 # Avoid potentially uninitialized $_ in process_commands file read loop
 120 # Implemented rm command with more than 1 arg and wildcards in rm args
 121 #
 122 # Revision 1.30  1997/11/06 14:09:53  ftplinux
 123 # In process_commands, also recognize commands given on the same line as
 124 # the Commands: keyword, not only the continuation lines.
 125 #
 126 # Revision 1.29  1997/11/03 15:52:20  ftplinux
 127 # After reopening the log file write one line to it for dqueued-watcher.
 128 #
 129 # Revision 1.28  1997/10/30 15:37:23  ftplinux
 130 # Removed some leftover comments in process_commands.
 131 # Changed pgp_check so that it returns the address of the signator.
 132 # process_commands now also logs PGP signator, since Uploader: address
 133 # can be choosen freely by uploader.
 134 #
 135 # Revision 1.27  1997/10/30 14:05:37  ftplinux
 136 # Added "command" to log string for command file uploader, to make it
 137 # unique for dqueued-watcher.
 138 #
 139 # Revision 1.26  1997/10/30 14:01:05  ftplinux
 140 # Implemented .commands files
 141 #
 142 # Revision 1.25  1997/10/30 13:05:29  ftplinux
 143 # Removed date from status version info (too long)
 144 #
 145 # Revision 1.24  1997/10/30 13:04:02  ftplinux
 146 # Print revision, version, and date in status data
 147 #
 148 # Revision 1.23  1997/10/30 12:56:01  ftplinux
 149 # Implemented deletion of files that (probably) belong to an upload, but
 150 # weren't listed in the .changes.
 151 #
 152 # Revision 1.22  1997/10/30 12:22:32  ftplinux
 153 # When setting sgid bit for stray files without a .changes, check for
 154 # files deleted in the meantime.
 155 #
 156 # Revision 1.21  1997/10/30 11:32:19  ftplinux
 157 # Added quotes where filenames are used on sh command lines, in case
 158 # they contain metacharacters.
 159 # print_time now always print three-field times, as omitting the hour if
 160 # 0 could cause confusing (hour or seconds missing?).
 161 # Implemented warning mails for incomplete uploads that miss a .changes
 162 # file. Maintainer address can be extracted from *.deb, *.diff.gz,
 163 # *.dsc, or *.tar.gz files with help of new utility functions
 164 # is_debian_file, get_maintainer, and debian_file_stem.
 165 #
 166 # Revision 1.20  1997/10/13 09:12:21  ftplinux
 167 # On some .changes errors (missing/bad PGP signature, no files) also log the
 168 # uploader
 169 #
 170 # Revision 1.19  1997/09/25 11:20:42  ftplinux
 171 # Bumped release number to 0.4
 172 #
 173 # Revision 1.18  1997/09/25 08:15:02  ftplinux
 174 # In process_changes, initialize some vars to avoid warnings
 175 # If first consistency checks failed, don't forget to delete .changes file
 176 #
 177 # Revision 1.17  1997/09/16 10:53:35  ftplinux
 178 # Made logging more verbose in queued and dqueued-watcher
 179 #
 180 # Revision 1.16  1997/08/12 09:54:39  ftplinux
 181 # Bumped release number
 182 #
 183 # Revision 1.15  1997/08/11 12:49:09  ftplinux
 184 # Implemented logfile rotating
 185 #
 186 # Revision 1.14  1997/08/11 11:35:05  ftplinux
 187 # Revised startup scheme so it works with the socket-based ssh-agent, too.
 188 # That watches whether its child still exists, so the go-to-background fork must be done before the ssh-agent.
 189 #
 190 # Revision 1.13  1997/08/11 08:48:31  ftplinux
 191 # Aaarg... forgot the alarm(0)'s
 192 #
 193 # Revision 1.12  1997/08/07 09:25:22  ftplinux
 194 # Added timeout for remote operations
 195 #
 196 # Revision 1.11  1997/07/28 13:20:38  ftplinux
 197 # Added release numner to startup message
 198 #
 199 # Revision 1.10  1997/07/28 11:23:39  ftplinux
 200 # $main::statusd_pid not necessarily defined in status daemon -- rewrite check
 201 # whether to delete pid file in signal handler.
 202 #
 203 # Revision 1.9  1997/07/28 08:12:16  ftplinux
 204 # Again revised SIGCHLD handling.
 205 # Set $SHELL to /bin/sh explicitly before starting ssh-agent.
 206 # Again raise ping timeout.
 207 #
 208 # Revision 1.8  1997/07/25 10:23:03  ftplinux
 209 # Made SIGCHLD handling more portable between perl versions
 210 #
 211 # Revision 1.7  1997/07/09 10:15:16  ftplinux
 212 # Change RCS Header: to Id:
 213 #
 214 # Revision 1.6  1997/07/09 10:13:53  ftplinux
 215 # Alternative implementation of status file as plain file (not FIFO), because
 216 # standard wu-ftpd doesn't allow retrieval of non-regular files. New config
 217 # option $statusdelay for this.
 218 #
 219 # Revision 1.5  1997/07/09 09:21:22  ftplinux
 220 # Little revisions to signal handling; status daemon should ignore SIGPIPE,
 221 # in case someone closes the FIFO before completely reading it; in fatal_signal,
 222 # only the main daemon should remove the pid file.
 223 #
 224 # Revision 1.4  1997/07/08 11:31:51  ftplinux
 225 # Print messages of ssh call in is_on_master to debug log.
 226 # In ssh call to remove bad files on master, the split() doesn't work
 227 #   anymore, now that I use -o'xxx y'. Use string interpolation and let
 228 #   the shell parse the stuff.
 229 #
 230 # Revision 1.3  1997/07/07 09:29:30  ftplinux
 231 # Call check_alive also if master hasn't been pinged for 8 hours.
 232 #
 233 # Revision 1.2  1997/07/03 13:06:49  ftplinux
 234 # Little last changes before beta release
 235 #
 236 # Revision 1.1.1.1  1997/07/03 12:54:59  ftplinux
 237 # Import initial sources
 238 #
 239 #
 240
 241 require 5.002;
 242 use strict;
 243 use POSIX;
 244 use POSIX qw( strftime sys_stat_h sys_wait_h signal_h );
 245 use Net::Ping;
 246 use Net::FTP;
 247 use Socket qw( PF_INET AF_INET SOCK_STREAM );
 248 use Config;
 249
 250 # ---------------------------------------------------------------------------
 251 #                                                               configuration
 252 # ---------------------------------------------------------------------------
 253
 254 package conf;
 255 ($conf::queued_dir = (($0 !~ m,^/,) ? POSIX::getcwd()."/" : "") . $0)
 256         =~ s,/[^/]+$,,;
 257 require "$conf::queued_dir/config";
 258 my $junk = $conf::debug; # avoid spurious warnings about unused vars
 259 $junk = $conf::ssh_key_file;
 260 $junk = $conf::stray_remove_timeout;
 261 $junk = $conf::problem_report_timeout;
 262 $junk = $conf::queue_delay;
 263 $junk = $conf::keep_files;
 264 $junk = $conf::valid_files;
 265 $junk = $conf::max_upload_retries;
 266 $junk = $conf::upload_delay_1;
 267 $junk = $conf::upload_delay_2;
 268 $junk = $conf::ar;
 269 $junk = $conf::gzip;
 270 $junk = $conf::cp;
 271 #$junk = $conf::ls;
 272 $junk = $conf::chmod;
 273 $junk = $conf::ftpdebug;
 274 $junk = $conf::ftptimeout;
 275 $junk = $conf::no_changes_timeout;
 276 $junk = @conf::nonus_packages;
 277 $junk = @conf::test_binaries;
 278 $junk = @conf::maintainer_mail;
 279 $junk = @conf::targetdir_delayed;
 280 $junk = $conf::mail ||= '/usr/sbin/sendmail';
 281 $conf::target = "localhost" if $conf::upload_method eq "copy";
 282 package main;
 283
 284 ($main::progname = $0) =~ s,.*/,,;
 285
 286 my %packages = ();
 287
 288 # extract -r and -k args
 289 $main::arg = "";
 290 if (@ARGV == 1 && $ARGV[0] =~ /^-[rk]$/) {
 291         $main::arg = ($ARGV[0] eq '-k') ? "kill" : "restart";
 292         shift @ARGV;
 293 }
 294
 295 # test for another instance of the queued already running
 296 my ($pid, $delayed_dirs, $adelayedcore);
 297 if (open( PIDFILE, "<$conf::pidfile" )) {
 298         chomp( $pid = <PIDFILE> );
 299         close( PIDFILE );
 300         if (!$pid) {
 301                 # remove stale pid file
 302                 unlink( $conf::pidfile );
 303         }
 304         elsif ($main::arg) {
 305                 local($|) = 1;
 306                 print "Killing running daemon (pid $pid) ...";
 307                 kill( 15, $pid );
 308                 my $cnt = 20;
 309                 while( kill( 0, $pid ) && $cnt-- > 0 ) {
 310                         sleep 1;
 311                         print ".";
 312                 }
 313                 if (kill( 0, $pid )) {
 314                         print " failed!\nProcess $pid still running.\n";
 315                         exit 1;
 316                 }
 317                 print "ok\n";
 318                 if (-e "$conf::incoming/core") {
 319                         unlink( "$conf::incoming/core" );
 320                         print "(Removed core file)\n";
 321                 }
 322                 for ($delayed_dirs = 0; $delayed_dirs <= $conf::max_delayed;
 323                          $delayed_dirs++) {
 324                         $adelayedcore = sprintf( "$conf::incoming_delayed/core",
 325                                                                          $delayed_dirs );
 326                         if (-e $adelayedcore) {
 327                                 unlink( $adelayedcore );
 328                                 print "(Removed core file)\n";
 329                         }
 330                 }
 331                 exit 0 if $main::arg eq "kill";
 332         }
 333         else {
 334                 die "Another $main::progname is already running (pid $pid)\n"
 335                         if $pid && kill( 0, $pid );
 336         }
 337 }
 338 elsif ($main::arg eq "kill") {
 339         die "No daemon running\n";
 340 }
 341 elsif ($main::arg eq "restart") {
 342         print "(No daemon running; starting anyway)\n";
 343 }
 344
 345 # if started without arguments (initial invocation), then fork
 346 if (!@ARGV) {
 347         # now go to background
 348         die "$main::progname: fork failed: $!\n" unless defined( $pid = fork );
 349         if ($pid) {
 350                 # parent: wait for signal from child (SIGCHLD or SIGUSR1) and exit
 351                 my $sigset = POSIX::SigSet->new();
 352                 $sigset->emptyset();
 353                 $SIG{"CHLD"} = sub { };
 354                 $SIG{"USR1"} = sub { };
 355                 POSIX::sigsuspend( $sigset );
 356                 waitpid( $pid, WNOHANG );
 357                 if (kill( 0, $pid )) {
 358                         print "Daemon started in background (pid $pid)\n";
 359                         exit 0;
 360                 }
 361                 else {
 362                         exit 1;
 363                 }
 364         }
 365         else {
 366                 # child
 367                 setsid;
 368                 if ($conf::upload_method eq "ssh") {
 369                         # exec an ssh-agent that starts us again
 370                         # force shell to be /bin/sh, ssh-agent may base its decision
 371                         # whether to use a fd or a Unix socket on the shell...
 372                         $ENV{"SHELL"} = "/bin/sh";
 373                         exec $conf::ssh_agent, $0, "startup", getppid();
 374                         die "$main::progname: Could not exec $conf::ssh_agent: $!\n";
 375                 }
 376                 else {
 377                         # no need to exec, just set up @ARGV as expected below
 378                         @ARGV = ("startup", getppid());
 379                 }
 380         }
 381 }
 382 die "Please start without any arguments.\n"
 383         if @ARGV != 2 || $ARGV[0] ne "startup";
 384 my $parent_pid = $ARGV[1];
 385
 386 do {
 387         my $version;
 388         ($version = 'Release: 0.9 $Revision: 1.51 $ $Date: 1999/07/08 09:43:21 $ $Author: ftplinux $') =~ s/\$ ?//g;
 389         print "debianqueued $version\n";
 390 };
 391
 392 # check if all programs exist
 393 my $prg;
 394 foreach $prg ( $conf::gpg, $conf::ssh, $conf::scp, $conf::ssh_agent,
 395                            $conf::ssh_add, $conf::md5sum, $conf::mail, $conf::mkfifo ) {
 396         die "Required program $prg doesn't exist or isn't executable\n"
 397                 if ! -x $prg;
 398 # check for correct upload method
 399 die "Bad upload method '$conf::upload_method'.\n"
 400         if $conf::upload_method ne "ssh" &&
 401            $conf::upload_method ne "ftp" &&
 402            $conf::upload_method ne "copy";
 403 die "No keyrings\n" if ! @conf::keyrings;
 404
 405 }
 406 die "statusfile path must be absolute."
 407         if $conf::statusfile !~ m,^/,;
 408 die "upload and target queue paths must be absolute."
 409         if $conf::incoming !~ m,^/, ||
 410            $conf::incoming_delayed !~ m,^/, ||
 411            $conf::targetdir !~ m,^/, ||
 412            $conf::targetdir_delayed !~ m,^/,;
 413
 414
 415 # ---------------------------------------------------------------------------
 416 #                                                          initializations
 417 # ---------------------------------------------------------------------------
 418
 419 # prototypes
 420 sub calc_delta();
 421 sub check_dir();
 422 sub get_filelist_from_known_good_changes($);
 423 sub age_delayed_queues();
 424 sub process_changes($\@);
 425 sub process_commands($);
 426 sub age_delayed_queues();
 427 sub is_on_target($\@);
 428 sub copy_to_target(@);
 429 sub pgp_check($);
 430 sub check_alive(;$);
 431 sub check_incoming_writable();
 432 sub fork_statusd();
 433 sub write_status_file();
 434 sub print_status($$$$$$);
 435 sub format_status_num(\$$);
 436 sub format_status_str(\$$);
 437 sub send_status();
 438 sub ftp_open();
 439 sub ftp_cmd($@);
 440 sub ftp_close();
 441 sub ftp_response();
 442 sub ftp_code();
 443 sub ftp_error();
 444 sub ssh_cmd($);
 445 sub scp_cmd(@);
 446 sub local_cmd($;$);
 447 sub check_alive(;$);
 448 sub check_incoming_writable();
 449 sub rm(@);
 450 sub md5sum($);
 451 sub is_debian_file($);
 452 sub get_maintainer($);
 453 sub debian_file_stem($);
 454 sub msg($@);
 455 sub debug(@);
 456 sub init_mail(;$);
 457 sub finish_mail();
 458 sub send_mail($$$);
 459 sub try_to_get_mail_addr($$);
 460 sub format_time();
 461 sub print_time($);
 462 sub block_signals();
 463 sub unblock_signals();
 464 sub close_log($);
 465 sub kid_died($);
 466 sub restart_statusd();
 467 sub fatal_signal($);
 468
 469 $ENV{"PATH"} = "/bin:/usr/bin";
 470 $ENV{"IFS"} = "" if defined($ENV{"IFS"} && $ENV{"IFS"} ne "");
 471
 472 # constants for stat
 473 sub ST_DEV()   { 0 }
 474 sub ST_INO()   { 1 }
 475 sub ST_MODE()  { 2 }
 476 sub ST_NLINK() { 3 }
 477 sub ST_UID()   { 4 }
 478 sub ST_GID()   { 5 }
 479 sub ST_RDEV()  { 6 }
 480 sub ST_SIZE()  { 7 }
 481 sub ST_ATIME() { 8 }
 482 sub ST_MTIME() { 9 }
 483 sub ST_CTIME() { 10 }
 484 # fixed lengths of data items passed over status pipe
 485 sub STATNUM_LEN() { 30 }
 486 sub STATSTR_LEN() { 128 }
 487
 488 # init list of signals
 489 defined $Config{sig_name} or die "$main::progname: No signal list defined!\n";
 490 my $i = 0;
 491 my $name;
 492 foreach $name (split( ' ', $Config{sig_name} )) {
 493         $main::signo{$name} = $i++;
 494 }
 495
 496 @main::fatal_signals = qw( INT QUIT ILL TRAP ABRT BUS FPE USR2 SEGV PIPE
 497                                                    TERM XCPU XFSZ PWR );
 498
 499 $main::block_sigset = POSIX::SigSet->new;
 500 $main::block_sigset->addset( $main::signo{"INT"} );
 501 $main::block_sigset->addset( $main::signo{"TERM"} );
 502
 503 # some constant net stuff
 504 $main::tcp_proto = (getprotobyname('tcp'))[2]
 505         or die "Cannot get protocol number for 'tcp'\n";
 506 my $used_service = ($conf::upload_method eq "ssh") ? "ssh" : "ftp";
 507 $main::echo_port = (getservbyname($used_service, 'tcp'))[2]
 508         or die "Cannot get port number for service '$used_service'\n";
 509
 510 # clear queue of stored mails
 511 @main::stored_mails = ();
 512
 513 # run ssh-add to bring the key into the agent (will use stdin/stdout)
 514 if ($conf::upload_method eq "ssh") {
 515         system "$conf::ssh_add $conf::ssh_key_file"
 516                 and die "$main::progname: Running $conf::ssh_add failed ".
 517                                 "(exit status ", $? >> 8, ")\n";
 518 }
 519
 520 # change to queue dir
 521 chdir( $conf::incoming )
 522         or die "$main::progname: cannot cd to $conf::incoming: $!\n";
 523
 524 # needed before /dev/null redirects, some system send a SIGHUP when loosing
 525 # the controlling tty
 526 $SIG{"HUP"} = "IGNORE";
 527
 528 # open logfile, make it unbuffered
 529 open( LOG, ">>$conf::logfile" )
 530         or die "Cannot open my logfile $conf::logfile: $!\n";
 531 chmod( 0644, $conf::logfile )
 532         or die "Cannot set modes of $conf::logfile: $!\n";
 533 select( (select(LOG), $| = 1)[0] );
 534
 535 sleep( 1 );
 536 $SIG{"HUP"} = \&close_log;
 537
 538 # redirect stdin, ... to /dev/null
 539 open( STDIN, "</dev/null" )
 540         or die "$main::progname: Can't redirect stdin to /dev/null: $!\n";
 541 open( STDOUT, ">&LOG" )
 542         or die "$main::progname: Can't redirect stdout to $conf::logfile: $!\n";
 543 open( STDERR, ">&LOG" )
 544         or die "$main::progname: Can't redirect stderr to $conf::logfile: $!\n";
 545 # ok, from this point usually no "die" anymore, stderr is gone!
 546 msg( "log", "daemon (pid $$) started\n" );
 547
 548 # initialize variables used by send_status before launching the status daemon
 549 $main::dstat = "i";
 550 format_status_num( $main::next_run, time+10 );
 551 format_status_str( $main::current_changes, "" );
 552 check_alive();
 553 $main::incoming_writable = 1; # assume this for now
 554
 555 # start the daemon watching the 'status' FIFO
 556 if ($conf::statusfile && $conf::statusdelay == 0) {
 557         $main::statusd_pid = fork_statusd();
 558         $SIG{"CHLD"} = \&kid_died; # watch out for dead status daemon
 559         # SIGUSR1 triggers status info
 560         $SIG{"USR1"} = \&send_status;
 561 }
 562 $main::maind_pid = $$;
 563
 564 END { kill( $main::signo{"ABRT"}, $$ ) if defined $main::signo{"ABRT"}; }
 565
 566 # write the pid file
 567 open( PIDFILE, ">$conf::pidfile" )
 568         or msg( "log", "Can't open $conf::pidfile: $!\n" );
 569 printf PIDFILE "%5d\n", $$;
 570 close( PIDFILE );
 571 chmod( 0644, $conf::pidfile )
 572         or die "Cannot set modes of $conf::pidfile: $!\n";
 573
 574 # other signals will just log an error and exit
 575 foreach ( @main::fatal_signals ) {
 576         $SIG{$_} = \&fatal_signal;
 577 }
 578
 579 # send signal to user-started process that we're ready and it can exit
 580 kill( $main::signo{"USR1"}, $parent_pid );
 581
 582 # ---------------------------------------------------------------------------
 583 #                                                                the mainloop
 584 # ---------------------------------------------------------------------------
 585
 586 # default to classical incoming/target
 587 $main::current_incoming = $conf::incoming;
 588 $main::current_targetdir = $conf::targetdir;
 589
 590 $main::dstat = "i";
 591 write_status_file() if $conf::statusdelay;
 592 while( 1 ) {
 593
 594         # ping target only if there is the possibility that we'll contact it (but
 595         # also don't wait too long).
 596         my @have_changes = <*.changes *.commands>;
 597         for ( my $delayed_dirs = 0; $delayed_dirs <= $conf::max_delayed;
 598                   $delayed_dirs++) {
 599                 my $adelayeddir = sprintf( "$conf::incoming_delayed",
 600                                                                    $delayed_dirs );
 601                 push( @have_changes,
 602                           <$adelayeddir/*.changes> );
 603         }
 604         check_alive() if @have_changes || (time - $main::last_ping_time) > 8*60*60;
 605
 606         if (@have_changes && $main::target_up) {
 607                 check_incoming_writable if !$main::incoming_writable;
 608                 check_dir() if $main::incoming_writable;
 609         }
 610         $main::dstat = "i";
 611         write_status_file() if $conf::statusdelay;
 612
 613         if ($conf::upload_method eq "copy") {
 614                 age_delayed_queues();
 615         }
 616
 617         # sleep() returns if we received a signal (SIGUSR1 for status FIFO), so
 618         # calculate the end time once and wait for it being reached.
 619         format_status_num( $main::next_run, time + $conf::queue_delay );
 620         my $delta;
 621         while( ($delta = calc_delta()) > 0 ) {
 622                 debug( "mainloop sleeping $delta secs" );
 623                 sleep( $delta );
 624                 # check if statusd died, if using status FIFO, or update status file
 625                 if ($conf::statusdelay) {
 626                         write_status_file();
 627                 }
 628                 else {
 629                         restart_statusd();
 630                 }
 631         }
 632 }
 633
 634 sub calc_delta() {
 635         my $delta;
 636
 637         $delta = $main::next_run - time;
 638         $delta = $conf::statusdelay
 639                 if $conf::statusdelay && $conf::statusdelay < $delta;
 640         return $delta;
 641 }
 642
 643
 644 # ---------------------------------------------------------------------------
 645 #                                                       main working functions
 646 # ---------------------------------------------------------------------------
 647
 648
 649 #
 650 # main function for checking the incoming dir
 651 #
 652 sub check_dir() {
 653         my( @files, @changes, @keep_files, @this_keep_files, @stats, $file ,
 654                 $adelay );
 655
 656         debug( "starting checkdir" );
 657         $main::dstat = "c";
 658         write_status_file() if $conf::statusdelay;
 659
 660         # test if needed binaries are available; this is if they're on maybe
 661         # slow-mounted NFS filesystems
 662         foreach (@conf::test_binaries) {
 663                 next if -f $_;
 664                 # maybe the mount succeeds now
 665                 sleep 5;
 666                 next if -f $_;
 667                 msg( "log", "binary test failed for $_; delaying queue run\n");
 668                 goto end_run;
 669         }
 670
 671         for ( $adelay=-1; $adelay <= $conf::max_delayed; $adelay++ ) {
 672                 if ( $adelay == -1 ) {
 673                         $main::current_incoming = $conf::incoming;
 674                         $main::current_incoming_short = "";
 675                         $main::current_targetdir = $conf::targetdir;
 676                 }
 677                 else {
 678                         $main::current_incoming = sprintf( $conf::incoming_delayed,
 679                                                                                            $adelay );
 680                         $main::current_incoming_short = sprintf( "DELAYED/%d-day",
 681                                                                                                          $adelay );
 682                         $main::current_targetdir = sprintf( $conf::targetdir_delayed,
 683                                                                                                 $adelay );
 684                 }
 685
 686                 # need to clear directory specific variables
 687                 undef ( @keep_files );
 688                 undef ( @this_keep_files );
 689
 690                 chdir ( $main::current_incoming )
 691                         or (msg( "log",
 692                                          "Cannot change to dir ".
 693                                          "${main::current_incoming_short}: $!\n" ),
 694                                 return);
 695
 696                 # look for *.commands files but not in delayed queues
 697                 if ( $adelay==-1 ) {
 698                         foreach $file ( <*.commands> ) {
 699                                 init_mail( $file );
 700                                 block_signals();
 701                                 process_commands( $file );
 702                                 unblock_signals();
 703                                 $main::dstat = "c";
 704                                 write_status_file() if $conf::statusdelay;
 705                                 finish_mail();
 706                         }
 707                 }
 708                 opendir( INC, "." )
 709                         or (msg( "log", "Cannot open dir ${main::current_incoming_short}: $!\n" ),
 710                                 return);
 711                 @files = readdir( INC );
 712                 closedir( INC );
 713
 714                 # process all .changes files found
 715                 @changes = grep /\.changes$/, @files;
 716                 push( @keep_files, @changes ); # .changes files aren't stray
 717                 foreach $file ( @changes ) {
 718                         init_mail( $file );
 719                         # wrap in an eval to allow jumpbacks to here with die in case
 720                         # of errors
 721                         block_signals();
 722                         eval { process_changes( $file, @this_keep_files ); };
 723                         unblock_signals();
 724                         msg( "log,mail", $@ ) if $@;
 725                         $main::dstat = "c";
 726                         write_status_file() if $conf::statusdelay;
 727
 728                         # files which are ok in conjunction with this .changes
 729                         debug( "$file tells to keep @this_keep_files" );
 730                         push( @keep_files, @this_keep_files );
 731                         finish_mail();
 732
 733                         # break out of this loop if the incoming dir has become unwritable
 734                         goto end_run if !$main::incoming_writable;
 735                 }
 736                 ftp_close() if $conf::upload_method eq "ftp";
 737
 738                 # find files which aren't related to any .changes
 739                 foreach $file ( @files ) {
 740                         # filter out files we never want to delete
 741                         next if ! -f $file ||   # may have disappeared in the meantime
 742                             $file eq "." || $file eq ".." ||
 743                             (grep { $_ eq $file } @keep_files) ||
 744                                 $file =~ /$conf::keep_files/;
 745                         # Delete such files if they're older than
 746                         # $stray_remove_timeout; they could be part of an
 747                         # yet-incomplete upload, with the .changes still missing.
 748                         # Cannot send any notification, since owner unknown.
 749                         next if !(@stats = stat( $file ));
 750                         my $age = time - $stats[ST_MTIME];
 751                         my( $maint, $pattern, @job_files );
 752                         if ($file =~ /^junk-for-writable-test/ ||
 753                                 $file !~ m,$conf::valid_files, ||
 754                                 $age >= $conf::stray_remove_timeout) {
 755                                 msg( "log", "Deleted stray file ${main::current_incoming_short}/$file\n" ) if rm( $file );
 756                         }
 757                         elsif ($age > $conf::no_changes_timeout &&
 758                                    is_debian_file( $file ) &&
 759                                    # not already reported
 760                                    !($stats[ST_MODE] & S_ISGID) &&
 761                                    ($pattern = debian_file_stem( $file )) &&
 762                                    (@job_files = glob($pattern)) &&
 763                                    # If a .changes is in the list, it has the same stem as the
 764                                    # found file (probably a .orig.tar.gz). Don't report in this
 765                                    # case.
 766                                    !(grep( /\.changes$/, @job_files ))) {
 767                                 $maint = get_maintainer( $file );
 768                                 # Don't send a mail if this looks like the recompilation of a
 769                                 # package for a non-i386 arch. For those, the maintainer field is
 770                                 # useless :-(
 771                                 if (!grep( /(\.dsc|_(i386|all)\.deb)$/, @job_files )) {
 772                                         msg( "log", "Found an upload without .changes and with no ",
 773                                                         ".dsc file\n" );
 774                                         msg( "log", "Not sending a report, because probably ",
 775                                                         "recompilation job\n" );
 776                                 }
 777                                 elsif ($maint) {
 778                                         init_mail();
 779                                         $main::mail_addr = $maint;
 780                                         $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
 781                                         $main::mail_subject = "Incomplete upload found in ".
 782                                                                   "Debian upload queue";
 783                                         msg( "mail", "Probably you are the uploader of the following ".
 784                                                                  "file(s) in\n" );
 785                                         msg( "mail", "the Debian upload queue directory:\n  " );
 786                                         msg( "mail", join( "\n  ", @job_files ), "\n" );
 787                                         msg( "mail", "This looks like an upload, but a .changes file ".
 788                                                                  "is missing, so the job\n" );
 789                                         msg( "mail", "cannot be processed.\n\n" );
 790                                         msg( "mail", "If no .changes file arrives within ",
 791                                                                  print_time( $conf::stray_remove_timeout - $age ),
 792                                                                  ", the files will be deleted.\n\n" );
 793                                         msg( "mail", "If you didn't upload those files, please just ".
 794                                                                  "ignore this message.\n" );
 795                                         finish_mail();
 796                                         msg( "log", "Sending problem report for an upload without a ".
 797                                                                 ".changes\n" );
 798                                         msg( "log", "Maintainer: $maint\n" );
 799                                 }
 800                                 else {
 801                                         msg( "log", "Found an upload without .changes, but can't ".
 802                                                                 "find a maintainer address\n" );
 803                                 }
 804                                 msg( "log", "Files: @job_files\n" );
 805                                 # remember we already have sent a mail regarding this file
 806                                 foreach ( @job_files ) {
 807                                         my @st = stat($_);
 808                                         next if !@st; # file may have disappeared in the meantime
 809                                         chmod +($st[ST_MODE] |= S_ISGID), $_;
 810                                 }
 811                         }
 812                         else {
 813                                 debug( "found stray file ${main::current_incoming_short}/$file, deleting in ",
 814                                            print_time($conf::stray_remove_timeout - $age) );
 815                         }
 816                 }
 817         }
 818         chdir( $conf::incoming );
 819
 820   end_run:
 821         $main::dstat = "i";
 822         write_status_file() if $conf::statusdelay;
 823 }
 824
 825 sub get_filelist_from_known_good_changes($) {
 826         my $changes = shift;
 827
 828         local( *CHANGES );
 829         my(@filenames);
 830
 831         # parse the .changes file
 832         open( CHANGES, "<$changes" )
 833                 or die "$changes: $!\n";
 834         outer_loop: while( <CHANGES> ) {
 835                 if (/^Files:/i) {
 836                         while( <CHANGES> ) {
 837                                 redo outer_loop if !/^\s/;
 838                                 my @field = split( /\s+/ );
 839                                 next if @field != 6;
 840                                 # forbid shell meta chars in the name, we pass it to a
 841                                 # subshell several times...
 842                                 $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/;
 843                                 if ($1 ne $field[5]) {
 844                                         msg( "log", "found suspicious filename $field[5]\n" );
 845                                         next;
 846                                 }
 847                                 push( @filenames, $field[5] );
 848                         }
 849                 }
 850         }
 851         close( CHANGES );
 852         return @filenames;
 853 }
 854
 855 #
 856 # process one .changes file
 857 #
 858 sub process_changes($\@) {
 859         my $changes = shift;
 860         my $keep_list = shift;
 861         my( $pgplines, @files, @filenames, @changes_stats, $failure_file,
 862             $retries, $last_retry, $upload_time, $file, $do_report, $ls_l,
 863             $problems_reported, $errs, $pkgname, $signator );
 864         local( *CHANGES );
 865         local( *FAILS );
 866
 867         format_status_str( $main::current_changes, "$main::current_incoming_short/$changes" );
 868         $main::dstat = "c";
 869         write_status_file() if $conf::statusdelay;
 870
 871         @$keep_list = ();
 872         msg( "log", "processing ${main::current_incoming_short}/$changes\n" );
 873
 874         # parse the .changes file
 875         open( CHANGES, "<$changes" )
 876                 or die "Cannot open ${main::current_incoming_short}/$changes: $!\n";
 877         $pgplines = 0;
 878         $main::mail_addr = "";
 879         @files = ();
 880         outer_loop: while( <CHANGES> ) {
 881                 if (/^---+(BEGIN|END) PGP .*---+$/) {
 882                         ++$pgplines;
 883                 }
 884                 elsif (/^Maintainer:\s*/i) {
 885                         chomp( $main::mail_addr = $' );
 886                         $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
 887                 }
 888                 elsif (/^Source:\s*/i) {
 889                         chomp( $pkgname = $' );
 890                         $pkgname =~ s/\s+$//;
 891                         $main::packages{$pkgname}++;
 892                 }
 893                 elsif (/^Files:/i) {
 894                         while( <CHANGES> ) {
 895                                 redo outer_loop if !/^\s/;
 896                                 my @field = split( /\s+/ );
 897                                 next if @field != 6;
 898                                 # forbid shell meta chars in the name, we pass it to a
 899                                 # subshell several times...
 900                                 $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/;
 901                                 if ($1 ne $field[5]) {
 902                                         msg( "log", "found suspicious filename $field[5]\n" );
 903                                         msg( "mail", "File '$field[5]' mentioned in $main::current_incoming_short/$changes\n",
 904                                                  "has bad characters in its name. Removed.\n" );
 905                                         rm( $field[5] );
 906                                         next;
 907                                 }
 908                                 push( @files, { md5  => $field[1],
 909                                                                 size => $field[2],
 910                                                                 name => $field[5] } );
 911                                 push( @filenames, $field[5] );
 912                                 debug( "includes file $field[5], size $field[2], ",
 913                                            "md5 $field[1]" );
 914                         }
 915                 }
 916         }
 917         close( CHANGES );
 918
 919         # tell check_dir that the files mentioned in this .changes aren't stray,
 920         # we know about them somehow
 921         @$keep_list = @filenames;
 922
 923         # some consistency checks
 924         if (!$main::mail_addr) {
 925                 msg( "log,mail", "$main::current_incoming_short/$changes doesn't contain a Maintainer: field; ".
 926                          "cannot process\n" );
 927                 goto remove_only_changes;
 928         }
 929         if ($main::mail_addr !~ /^(buildd_\S+-\S+|\S+\@\S+\.\S+)/) {
 930                 # doesn't look like a mail address, maybe only the name
 931                 my( $new_addr, @addr_list );
 932                 if ($new_addr = try_to_get_mail_addr( $main::mail_addr, \@addr_list )){
 933                         # substitute (unique) found addr, but give a warning
 934                         msg( "mail", "(The Maintainer: field didn't contain a proper ".
 935                                                  "mail address.\n" );
 936                         msg( "mail", "Looking for `$main::mail_addr' in the Debian ".
 937                                                  "keyring gave your address\n" );
 938                         msg( "mail", "as unique result, so I used this.)\n" );
 939                         msg( "log", "Substituted $new_addr for malformed ".
 940                                                 "$main::mail_addr\n" );
 941                         $main::mail_addr = $new_addr;
 942                 }
 943                 else {
 944                         # not found or not unique: hold the job and inform queue maintainer
 945                         my $old_addr = $main::mail_addr;
 946                         $main::mail_addr = $conf::maintainer_mail;
 947                         msg( "mail", "The job ${main::current_incoming_short}/$changes doesn't have a correct email\n" );
 948                     msg( "mail", "address in the Maintainer: field:\n" );
 949                         msg( "mail", "  $old_addr\n" );
 950                         msg( "mail", "A check for this in the Debian keyring gave:\n" );
 951                         msg( "mail", @addr_list ?
 952                                                  "  " . join( ", ", @addr_list ) . "\n" :
 953                                                  "  nothing\n" );
 954                         msg( "mail", "Please fix this manually\n" );
 955                         msg( "log", "Bad Maintainer: field in ${main::current_incoming_short}/$changes: $old_addr\n" );
 956                         goto remove_only_changes;
 957                 }
 958         }
 959         if ($pgplines < 3) {
 960                 msg( "log,mail", "$main::current_incoming_short/$changes isn't signed with PGP/GnuPG\n" );
 961                 msg( "log", "(uploader $main::mail_addr)\n" );
 962                 goto remove_only_changes;
 963         }
 964         if (!@files) {
 965                 msg( "log,mail", "$main::current_incoming_short/$changes doesn't mention any files\n" );
 966                 msg( "log", "(uploader $main::mail_addr)\n" );
 967                 goto remove_only_changes;
 968         }
 969
 970         # check for packages that shouldn't be processed
 971         if (grep( $_ eq $pkgname, @conf::nonus_packages )) {
 972                 msg( "log,mail", "$pkgname is a package that must be uploaded ".
 973                                      "to nonus.debian.org\n" );
 974                 msg( "log,mail", "instead of target.\n" );
 975                 msg( "log,mail", "Job rejected and removed all files belonging ".
 976                                                  "to it:\n" );
 977                 msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
 978                 rm( $changes, @filenames );
 979                 return;
 980         }
 981
 982         $failure_file = $changes . ".failures";
 983         $retries = $last_retry = 0;
 984         if (-f $failure_file) {
 985                 open( FAILS, "<$failure_file" )
 986                         or die "Cannot open $main::current_incoming_short/$failure_file: $!\n";
 987                 my $line = <FAILS>;
 988                 close( FAILS );
 989                 ( $retries, $last_retry ) = ( $1, $2 ) if $line =~ /^(\d+)\s+(\d+)$/;
 990                 push( @$keep_list, $failure_file );
 991         }
 992
 993         # run PGP on the file to check the signature
 994         if (!($signator = pgp_check( $changes ))) {
 995                 msg( "log,mail", "$main::current_incoming_short/$changes has bad PGP/GnuPG signature!\n" );
 996                 msg( "log", "(uploader $main::mail_addr)\n" );
 997           remove_only_changes:
 998                 msg( "log,mail", "Removing $main::current_incoming_short/$changes, but keeping its associated ",
 999                                      "files for now.\n" );
1000                 rm( $changes );
1001                 # Set SGID bit on associated files, so that the test for Debian files
1002                 # without a .changes doesn't consider them.
1003                 foreach ( @filenames ) {
1004                         my @st = stat($_);
1005                         next if !@st; # file may have disappeared in the meantime
1006                         chmod +($st[ST_MODE] |= S_ISGID), $_;
1007                 }
1008                 return;
1009         }
1010         elsif ($signator eq "LOCAL ERROR") {
1011                 # An error has appened when starting pgp... Don't process the file,
1012                 # but also don't delete it
1013                 debug( "Can't PGP/GnuPG check $main::current_incoming_short/$changes -- don't process it for now" );
1014                 return;
1015         }
1016
1017         die "Cannot stat ${main::current_incoming_short}/$changes (??): $!\n"
1018                 if !(@changes_stats = stat( $changes ));
1019         # Make $upload_time the maximum of all modification times of files
1020         # related to this .changes (and the .changes it self). This is the
1021         # last time something changes to these files.
1022         $upload_time = $changes_stats[ST_MTIME];
1023         for $file ( @files ) {
1024                 my @stats;
1025                 next if !(@stats = stat( $file->{"name"} ));
1026                 $file->{"stats"} = \@stats;
1027                 $upload_time = $stats[ST_MTIME] if $stats[ST_MTIME] > $upload_time;
1028         }
1029
1030         $do_report = (time - $upload_time) > $conf::problem_report_timeout;
1031         $problems_reported = $changes_stats[ST_MODE] & S_ISGID;
1032         # if any of the files is newer than the .changes' ctime (the time
1033         # we sent a report and set the sticky bit), send new problem reports
1034         if ($problems_reported && $changes_stats[ST_CTIME] < $upload_time) {
1035                 $problems_reported = 0;
1036                 chmod +($changes_stats[ST_MODE] &= ~S_ISGID), $changes;
1037                 debug( "upload_time>changes-ctime => resetting problems reported" );
1038         }
1039         debug( "do_report=$do_report problems_reported=$problems_reported" );
1040
1041         # now check all files for correct size and md5 sum
1042         for $file ( @files ) {
1043                 my $filename = $file->{"name"};
1044                 if (!defined( $file->{"stats"} )) {
1045                         # could be an upload that isn't complete yet, be quiet,
1046                         # but don't process the file;
1047                         msg( "log,mail", "$filename doesn't exist\n" )
1048                                 if $do_report && !$problems_reported;
1049                         msg( "log", "$filename doesn't exist (ignored for now)\n" )
1050                                 if !$do_report;
1051                         msg( "log", "$filename doesn't exist (already reported)\n" )
1052                                 if $problems_reported;
1053                         ++$errs;
1054                 }
1055                 elsif ($file->{"stats"}->[ST_SIZE] < $file->{"size"} && !$do_report) {
1056                         # could be an upload that isn't complete yet, be quiet,
1057                         # but don't process the file
1058                         msg( "log", "$filename is too small (ignored for now)\n" );
1059                         ++$errs;
1060                 }
1061                 elsif ($file->{"stats"}->[ST_SIZE] != $file->{"size"}) {
1062                         msg( "log,mail", "$filename has incorrect size; deleting it\n" );
1063                         rm( $filename );
1064                         ++$errs;
1065                 }
1066                 elsif (md5sum( $filename ) ne $file->{"md5"}) {
1067                         msg( "log,mail", "$filename has incorrect md5 checksum; ",
1068                                              "deleting it\n" );
1069                         rm( $filename );
1070                         ++$errs;
1071                 }
1072         }
1073
1074         if ($errs) {
1075                 if ((time - $upload_time) > $conf::bad_changes_timeout) {
1076                         # if a .changes fails for a really long time (several days
1077                         # or so), remove it and all associated files
1078                         msg( "log,mail",
1079                                  "$main::current_incoming_short/$changes couldn't be processed for ",
1080                                  int($conf::bad_changes_timeout/(60*60)),
1081                                  " hours and is now deleted\n" );
1082                         msg( "log,mail",
1083                                  "All files it mentions are also removed:\n" );
1084                         msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
1085                         rm( $changes, @filenames, $failure_file );
1086                 }
1087                 elsif ($do_report && !$problems_reported) {
1088                         # otherwise, send a problem report, if not done already
1089                         msg( "mail",
1090                                  "Due to the errors above, the .changes file couldn't ",
1091                                  "be processed.\n",
1092                                  "Please fix the problems for the upload to happen.\n" );
1093                         # remember we already have sent a mail regarding this file
1094                         debug( "Sending problem report mail and setting SGID bit" );
1095                         my $mode = $changes_stats[ST_MODE] |= S_ISGID;
1096                         msg( "log", "chmod failed: $!" ) if (chmod ($mode, $changes) != 1);
1097                 }
1098                 # else: be quiet
1099
1100                 return;
1101         }
1102
1103         # if this upload already failed earlier, wait until the delay requirement
1104         # is fulfilled
1105         if ($retries > 0 && (time - $last_retry) <
1106                 ($retries == 1 ? $conf::upload_delay_1 : $conf::upload_delay_2)) {
1107                 msg( "log", "delaying retry of upload\n" );
1108                 return;
1109         }
1110
1111         if ($conf::upload_method eq "ftp") {
1112                 return if !ftp_open();
1113         }
1114
1115         # check if the job is already present on target
1116         # (moved to here, to avoid bothering target as long as there are errors in
1117         # the job)
1118         if ($ls_l = is_on_target( $changes, @filenames )) {
1119                 msg( "log,mail", "$main::current_incoming_short/$changes is already present on target host:\n" );
1120                 msg( "log,mail", "$ls_l\n" );
1121                 msg( "mail", "Either you already uploaded it, or someone else ",
1122                                  "came first.\n" );
1123                 msg( "log,mail", "Job $changes removed.\n" );
1124                 rm( $changes, @filenames, $failure_file );
1125                 return;
1126         }
1127
1128         # clear sgid bit before upload, scp would copy it to target. We don't need
1129         # it anymore, we know there are no problems if we come here. Also change
1130         # mode of files to 644 if this should be done locally.
1131         $changes_stats[ST_MODE] &= ~S_ISGID;
1132         if (!$conf::chmod_on_target) {
1133                 $changes_stats[ST_MODE] &= ~0777;
1134                 $changes_stats[ST_MODE] |= 0644;
1135         }
1136         chmod +($changes_stats[ST_MODE]), $changes;
1137
1138         # try uploading to target
1139         if (!copy_to_target( $changes, @filenames )) {
1140                 # if the upload failed, increment the retry counter and remember the
1141                 # current time; both things are written to the .failures file. Don't
1142                 # increment the fail counter if the error was due to incoming
1143                 # unwritable.
1144                 return if !$main::incoming_writable;
1145                 if (++$retries >= $conf::max_upload_retries) {
1146                         msg( "log,mail",
1147                                  "$changes couldn't be uploaded for $retries times now.\n" );
1148                         msg( "log,mail",
1149                                  "Giving up and removing it and its associated files:\n" );
1150                         msg( "log,mail", "  ", join( ", ", @filenames ), "\n" );
1151                         rm( $changes, @filenames, $failure_file );
1152                 }
1153                 else {
1154                         $last_retry = time;
1155                         if (open( FAILS, ">$failure_file" )) {
1156                                 print FAILS "$retries $last_retry\n";
1157                                 close( FAILS );
1158                                 chmod( 0600, $failure_file )
1159                                         or die "Cannot set modes of $failure_file: $!\n";
1160                         }
1161                         push( @$keep_list, $failure_file );
1162                         debug( "now $retries failed uploads" );
1163                         msg( "mail",
1164                                  "The upload will be retried in ",
1165                                  print_time( $retries == 1 ? $conf::upload_delay_1 :
1166                                                          $conf::upload_delay_2 ), "\n" );
1167                 }
1168                 return;
1169         }
1170
1171         # If the files were uploaded ok, remove them
1172         rm( $changes, @filenames, $failure_file );
1173
1174         msg( "mail", "$changes uploaded successfully to $conf::target\n" );
1175         msg( "mail", "along with the files:\n  ",
1176                          join( "\n  ", @filenames ), "\n" );
1177         msg( "log", "$changes processed successfully (uploader $main::mail_addr)\n" );
1178
1179         # Check for files that have the same stem as the .changes (and weren't
1180         # mentioned there) and delete them. It happens often enough that people
1181         # upload a .orig.tar.gz where it isn't needed and also not in the
1182         # .changes. Explicitly deleting it (and not waiting for the
1183         # $stray_remove_timeout) reduces clutter in the queue dir and maybe also
1184         # educates uploaders :-)
1185
1186 #       my $pattern = debian_file_stem( $changes );
1187 #       my $spattern = substr( $pattern, 0, -1 ); # strip off '*' at end
1188 #       my @other_files = glob($pattern);
1189         # filter out files that have a Debian revision at all and a different
1190         # revision. Those belong to a different upload.
1191 #       if ($changes =~ /^\Q$spattern\E-([\d.+-]+)/) {
1192 #               my $this_rev = $1;
1193 #               @other_files = grep( !/^\Q$spattern\E-([\d.+-]+)/ || $1 eq $this_rev,
1194 #                                                        @other_files);
1195         #}
1196         # Also do not remove those files if a .changes is among them. Then there
1197         # is probably a second upload for another version or another architecture.
1198 #       if (@other_files && !grep( /\.changes$/, @other_files )) {
1199 #               rm( @other_files );
1200 #               msg( "mail", "\nThe following file(s) seemed to belong to the same ".
1201 #                                        "upload, but weren't listed\n" );
1202 #               msg( "mail", "in the .changes file:\n  " );
1203 #               msg( "mail", join( "\n  ", @other_files ), "\n" );
1204 #               msg( "mail", "They have been deleted.\n" );
1205 #               msg( "log", "Deleted files in upload not in $changes: @other_files\n" );
1206         #}
1207 }
1208
1209 #
1210 # process one .commands file
1211 #
1212 sub process_commands($) {
1213         my $commands = shift;
1214         my( @cmds, $cmd, $pgplines, $signator );
1215         local( *COMMANDS );
1216         my( @files, $file, @removed, $target_delay );
1217
1218         format_status_str( $main::current_changes, $commands );
1219         $main::dstat = "c";
1220         write_status_file() if $conf::statusdelay;
1221
1222         msg( "log", "processing $main::current_incoming_short/$commands\n" );
1223
1224         # parse the .commands file
1225         if (!open( COMMANDS, "<$commands" )) {
1226                 msg( "log", "Cannot open $main::current_incoming_short/$commands: $!\n" );
1227                 return;
1228         }
1229         $pgplines = 0;
1230         $main::mail_addr = "";
1231         @cmds = ();
1232         outer_loop: while( <COMMANDS> ) {
1233                 if (/^---+(BEGIN|END) PGP .*---+$/) {
1234                         ++$pgplines;
1235                 }
1236                 elsif (/^Uploader:\s*/i) {
1237                         chomp( $main::mail_addr = $' );
1238                         $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
1239                 }
1240                 elsif (/^Commands:/i) {
1241                         $_ = $';
1242                         for(;;) {
1243                                 s/^\s*(.*)\s*$/$1/; # delete whitespace at both ends
1244                                 if (!/^\s*$/) {
1245                                         push( @cmds, $_ );
1246                                         debug( "includes cmd $_" );
1247                                 }
1248                                 last outer_loop if !defined( $_ = scalar(<COMMANDS>) );
1249                                 chomp;
1250                                 redo outer_loop if !/^\s/ || /^$/;
1251                         }
1252                 }
1253         }
1254         close( COMMANDS );
1255
1256         # some consistency checks
1257         if (!$main::mail_addr || $main::mail_addr !~ /^\S+\@\S+\.\S+/) {
1258                 msg( "log,mail", "$main::current_incoming_short/$commands contains no or bad Uploader: field: ".
1259                                                  "$main::mail_addr\n" );
1260                 msg( "log,mail", "cannot process $main::current_incoming_short/$commands\n" );
1261                 $main::mail_addr = "";
1262                 goto remove;
1263         }
1264         msg( "log", "(command uploader $main::mail_addr)\n" );
1265
1266         if ($pgplines < 3) {
1267                 msg( "log,mail", "$main::current_incoming_short/$commands isn't signed with PGP/GnuPG\n" );
1268                 msg( "mail", "or the uploaded file is broken. Make sure to transfer in binary mode\n" );
1269                 msg( "mail", "or better yet - use dcut for commands files\n");
1270                 goto remove;
1271         }
1272
1273         # run PGP on the file to check the signature
1274         if (!($signator = pgp_check( $commands ))) {
1275                 msg( "log,mail", "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n" );
1276           remove:
1277                 msg( "log,mail", "Removing $main::current_incoming_short/$commands\n" );
1278                 rm( $commands );
1279                 return;
1280         }
1281         elsif ($signator eq "LOCAL ERROR") {
1282                 # An error has appened when starting pgp... Don't process the file,
1283                 # but also don't delete it
1284                 debug( "Can't PGP/GnuPG check $main::current_incoming_short/$commands -- don't process it for now" );
1285                 return;
1286         }
1287         msg( "log", "(PGP/GnuPG signature by $signator)\n" );
1288
1289         # now process commands
1290         msg( "mail", "Log of processing your commands file $main::current_incoming_short/$commands:\n\n" );
1291         foreach $cmd ( @cmds ) {
1292                 my @word = split( /\s+/, $cmd );
1293                 msg( "mail,log", "> @word\n" );
1294                 next if @word < 1;
1295
1296                 if ($word[0] eq "rm") {
1297                         foreach ( @word[1..$#word] ) {
1298                                 if (m,/,) {
1299                                         msg( "mail,log", "$_: filename may not contain slashes\n" );
1300                                 }
1301                                 elsif (/[*?[]/) {
1302                                         # process wildcards but also plain names (for delayed target removal)
1303                                         my (@thesefiles);
1304                                         my $pat = quotemeta($_);
1305                                         $pat =~ s/\\\*/.*/g;
1306                                         $pat =~ s/\\\?/.?/g;
1307                                         $pat =~ s/\\([][])/$1/g;
1308                                         opendir( DIR, "." );
1309                                         push (@thesefiles, grep /^$pat$/, readdir(DIR) );
1310                                         closedir( DIR );
1311                                         for ( my($adelay)=0; (! @thesefiles) && $adelay <= $conf::max_delayed; $adelay++ ) {
1312                                                 my($dir) = sprintf( $conf::incoming_delayed,
1313                                                                     $adelay );
1314                                                 opendir( DIR, "$dir" );
1315                                                 push( @thesefiles, map ("$dir/$_", grep /^$pat$/, readdir(DIR) ));
1316                                                 closedir( DIR );
1317                                         }
1318                                         push (@files, @thesefiles);
1319                                         if (! @thesefiles) {
1320                                                 msg( "mail,log", "$_ did not match anything\n" );
1321                                         }
1322                                 }
1323                                 else {
1324                                     my (@thesefiles);
1325                                     $file = $_;
1326                                     if (-f $file) {
1327                                                 push (@thesefiles, $file);
1328                                         }
1329                                         for ( my($adelay)=0; $adelay <= $conf::max_delayed; $adelay++ ) {
1330                                                 my($dir) = sprintf( $conf::incoming_delayed, $adelay );
1331                                                 if (-f "$dir/$file") {
1332                                                         push (@thesefiles, "$dir/$file");
1333                                                 }
1334                                     }
1335                                         if ($file =~ m/\.changes$/ &&  $conf::upload_method eq "copy") {
1336                                                 for ( my($adelay)=0; $adelay <= $conf::max_delayed; $adelay++ ) {
1337                                                         my($dir) = sprintf( "$conf::targetdir_delayed",$adelay );
1338                                                         if (-f "$dir/$file") {
1339                                                                 push (@thesefiles, "$dir/$file");
1340                                                                 push (@thesefiles, map( "$dir/$_",get_filelist_from_known_good_changes("$dir/$file")));
1341                                                         }
1342                                                 }
1343                                         }
1344                                         if (!@thesefiles) {
1345                                                 msg( "mail,log", "No file found: $file\n" );
1346                                         }
1347                                         push (@files, @thesefiles);
1348                                 }
1349                         }
1350                         if (!@files) {
1351                                 msg( "mail,log", "No files to delete\n" );
1352                         }
1353                         else {
1354                                 @removed = ();
1355                                 foreach $file ( @files ) {
1356                                         if (!-f $file) {
1357                                                 msg( "mail,log", "$file: no such file\n" );
1358                                         }
1359                                         elsif ($file =~ /$conf::keep_files/) {
1360                                                 msg( "mail,log", "$file is protected, cannot ".
1361                                                          "remove\n" );
1362                                         }
1363                                         elsif (!unlink( $file )) {
1364                                                 msg( "mail,log", "$file: rm: $!\n" );
1365                                         }
1366                                         else {
1367                                                 push( @removed, $file );
1368                                         }
1369                                 }
1370                                 msg( "mail,log", "Files removed: @removed\n" ) if @removed;
1371                         }
1372                 }
1373                 elsif ($word[0] eq "mv") {
1374                         if (@word != 3) {
1375                                 msg( "mail,log", "Wrong number of arguments\n" );
1376                         }
1377                         elsif ($word[1] =~ m,/, || $word[1] !~ m/\.changes/) {
1378                                 msg( "mail,log", "$word[1]: filename may not contain slashes\n" );
1379                         }
1380                         elsif (! (($target_delay) = $word[2] =~ m,^([0-9]+)-day$,) || $target_delay > $conf::max_delayed) {
1381                                 msg( "mail,log", "$word[2]: target must be #-day with # between 0 and $conf::max_delayed\n");
1382                         }
1383                         elsif ($word[1] =~ /$conf::keep_files/) {
1384                                 msg( "mail,log", "$word[1] is protected, cannot rename\n" );
1385                         }
1386                         else {
1387                                 my($adelay);
1388                                 for ( $adelay=0; $adelay <= $conf::max_delayed && ! -f (sprintf( "$conf::targetdir_delayed",$adelay )."/$word[1]"); $adelay++ ) {
1389                                 }
1390                                 if ( $adelay > $conf::max_delayed) {
1391                                         msg( "mail,log", "$word[1] not found\n" );
1392                                 }
1393                                 elsif ($adelay == $target_delay) {
1394                                         msg( "mail,log", "$word[1] already is in $word[2]\n" );
1395                                 }
1396                                 else {
1397                                         my(@thesefiles);
1398                                         my($dir) = sprintf( "$conf::targetdir_delayed",$adelay );
1399                                         my($target_dir) = sprintf( "$conf::targetdir_delayed",$target_delay );
1400                                         push (@thesefiles, $word[1]);
1401                                         push (@thesefiles, get_filelist_from_known_good_changes("$dir/$word[1]"));
1402                                         for my $afile(@thesefiles) {
1403                                                 if (! rename "$dir/$afile","$target_dir/$afile") {
1404                                                         msg( "mail,log", "rename: $!\n" );
1405                                                 }
1406                                                 else {
1407                                                         msg( "mail,log", "$afile moved to $target_delay-day\n" );
1408                                                 }
1409                                         }
1410                                 }
1411                         }
1412                 }
1413                 else {
1414                         msg( "mail,log", "unknown command $word[0]\n" );
1415                 }
1416         }
1417         rm( $commands );
1418         msg( "log", "-- End of $main::current_incoming_short/$commands processing\n" );
1419 }
1420
1421 sub age_delayed_queues() {
1422         for ( my($adelay)=0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
1423                 my($dir) = sprintf( "$conf::targetdir_delayed",$adelay );
1424                 my($target_dir);
1425                 if ($adelay == 0) {
1426                     $target_dir = $conf::targetdir;
1427                 }
1428                 else {
1429                         $target_dir = sprintf( "$conf::targetdir_delayed",$adelay-1 );
1430                 }
1431                 for my $achanges (<$dir/*.changes>) {
1432                         my $mtime = (stat($achanges))[9];
1433                         if ($mtime + 24*60*60 <= time) {
1434                                 utime undef,undef,($achanges);
1435                                 my @thesefiles = ($achanges =~ m,.*/([^/]*),);
1436                                 push (@thesefiles, get_filelist_from_known_good_changes($achanges));
1437                                 for my $afile(@thesefiles) {
1438                                         if (! rename "$dir/$afile","$target_dir/$afile") {
1439                                                 msg( "log", "rename: $!\n" );
1440                                         }
1441                                         else {
1442                                                 msg( "log", "$afile moved to $target_dir\n" );
1443                                         }
1444                                 }
1445                         }
1446                 }
1447         }
1448 }
1449
1450 #
1451 # check if a file is already on target
1452 #
1453 sub is_on_target($\@) {
1454         my $file = shift;
1455         my $filelist = shift;
1456         my $msg;
1457         my $stat;
1458
1459         if ($conf::upload_method eq "ssh") {
1460                 ($msg, $stat) = ssh_cmd( "ls -l $file" );
1461         }
1462         elsif ($conf::upload_method eq "ftp") {
1463                 my $err;
1464                 ($msg, $err) = ftp_cmd( "dir", $file );
1465                 if ($err) {
1466                         $stat = 1;
1467                         $msg = $err;
1468                 }
1469                 elsif (!$msg) {
1470                         $stat = 1;
1471                         $msg = "ls: no such file\n";
1472                 }
1473                 else {
1474                         $stat = 0;
1475                         $msg = join( "\n", @$msg );
1476                 }
1477         }
1478         else {
1479                 my @allfiles = ($file);
1480                 push ( @allfiles, @$filelist);
1481                 $stat = 1;
1482                 $msg = "no such file";
1483                 for my $afile(@allfiles) {
1484                         if (-f "$conf::incoming/$afile") {
1485                                 $stat = 0;
1486                     $msg = "$afile";
1487                         }
1488                 }
1489                 for ( my($adelay)=0 ; $adelay <= $conf::max_delayed && $stat ; $adelay++ ) {
1490                         for my $afile(@allfiles) {
1491                                 if (-f (sprintf( "$conf::targetdir_delayed",$adelay )."/$afile")) {
1492                                         $stat = 0;
1493                                         $msg = sprintf( "%d-day",$adelay )."/$afile";
1494                                 }
1495                         }
1496                 }
1497         }
1498         chomp( $msg );
1499         debug( "exit status: $stat, output was: $msg" );
1500
1501         return "" if $stat && $msg =~ /no such file/i; # file not present
1502         msg( "log", "strange ls -l output on target:\n", $msg ), return ""
1503                 if $stat || $@; # some other error, but still try to upload
1504
1505         # ls -l returned 0 -> file already there
1506         $msg =~ s/\s\s+/ /g; # make multiple spaces into one, to save space
1507         return $msg;
1508 }
1509
1510 #
1511 # copy a list of files to target
1512 #
1513 sub copy_to_target(@) {
1514         my @files = @_;
1515         my( @md5sum, @expected_files, $sum, $name, $msgs, $stat );
1516
1517         $main::dstat = "u";
1518         write_status_file() if $conf::statusdelay;
1519
1520         # copy the files
1521         if ($conf::upload_method eq "ssh") {
1522                 ($msgs, $stat) = scp_cmd( @files );
1523                 goto err if $stat;
1524         }
1525         elsif ($conf::upload_method eq "ftp") {
1526                 my($rv, $file);
1527                 if (!$main::FTP_chan->cwd( $main::current_targetdir )) {
1528                         msg( "log,mail", "Can't cd to $main::current_targetdir on $conf::target\n" );
1529                         goto err;
1530                 }
1531                 foreach $file (@files) {
1532                         ($rv, $msgs) = ftp_cmd( "put", $file );
1533                         goto err if !$rv;
1534                 }
1535         }
1536         else {
1537                 ($msgs, $stat) = local_cmd( "$conf::cp @files $main::current_targetdir", 'NOCD' );
1538                 goto err if $stat;
1539         }
1540
1541         # check md5sums or sizes on target against our own
1542         my $have_md5sums = 1;
1543         if ($conf::upload_method eq "ssh") {
1544                 ($msgs, $stat) = ssh_cmd( "md5sum @files" );
1545                 goto err if $stat;
1546                 @md5sum = split( "\n", $msgs );
1547         }
1548         elsif ($conf::upload_method eq "ftp") {
1549                 my ($rv, $err, $file);
1550                 foreach $file (@files) {
1551                         ($rv, $err) = ftp_cmd( "quot", "site", "md5sum", $file );
1552                         if ($err) {
1553                                 next if ftp_code() == 550; # file not found
1554                                 if (ftp_code() == 500) { # unimplemented
1555                                         $have_md5sums = 0;
1556                                         goto get_sizes_instead;
1557                                 }
1558                                 $msgs = $err;
1559                                 goto err;
1560                         }
1561                         chomp( my $t = ftp_response() );
1562                         push( @md5sum, $t );
1563                 }
1564                 if (!$have_md5sums) {
1565                   get_sizes_instead:
1566                         foreach $file (@files) {
1567                                 ($rv, $err) = ftp_cmd( "size", $file );
1568                                 if ($err) {
1569                                         next if ftp_code() == 550; # file not found
1570                                         $msgs = $err;
1571                                         goto err;
1572                                 }
1573                                 push( @md5sum, "$rv $file" );
1574                         }
1575                 }
1576         }
1577         else {
1578                 ($msgs, $stat) = local_cmd( "$conf::md5sum @files" );
1579                 goto err if $stat;
1580                 @md5sum = split( "\n", $msgs );
1581         }
1582
1583         @expected_files = @files;
1584         foreach (@md5sum) {
1585                 chomp;
1586                 ($sum,$name) = split;
1587                 next if !grep { $_ eq $name } @files; # a file we didn't upload??
1588                 next if $sum eq "md5sum:"; # looks like an error message
1589                 if (($have_md5sums && $sum ne md5sum( $name )) ||
1590                         (!$have_md5sums && $sum != (-s $name))) {
1591                         msg( "log,mail", "Upload of $name to $conf::target failed ",
1592                                  "(".($have_md5sums ? "md5sum" : "size")." mismatch)\n" );
1593                         goto err;
1594                 }
1595                 # seen that file, remove it from expect list
1596                 @expected_files = map { $_ eq $name ? () : $_ } @expected_files;
1597         }
1598         if (@expected_files) {
1599                 msg( "log,mail", "Failed to upload the files\n" );
1600                 msg( "log,mail", "  ", join( ", ", @expected_files ), "\n" );
1601                 msg( "log,mail", "(Not present on target after upload)\n" );
1602                 goto err;
1603         }
1604
1605         if ($conf::chmod_on_target) {
1606                 # change file's mode explicitly to 644 on target
1607                 if ($conf::upload_method eq "ssh") {
1608                         ($msgs, $stat) = ssh_cmd( "chmod 644 @files" );
1609                         goto err if $stat;
1610                 }
1611                 elsif ($conf::upload_method eq "ftp") {
1612                         my ($rv, $file);
1613                         foreach $file (@files) {
1614                                 ($rv, $msgs) = ftp_cmd( "quot", "site", "chmod", "644", $file );
1615                                 msg( "log", "Can't chmod $file on target:\n$msgs" )
1616                                         if $msgs;
1617                                 goto err if !$rv;
1618                         }
1619                 }
1620                 else {
1621                         ($msgs, $stat) = local_cmd( "$conf::chmod 644 @files" );
1622                         goto err if $stat;
1623                 }
1624         }
1625
1626         $main::dstat = "c";
1627         write_status_file() if $conf::statusdelay;
1628         return 1;
1629
1630   err:
1631         msg( "log,mail", "Upload to $conf::target failed",
1632                  $? ? ", last exit status ".sprintf( "%s", $?>>8 ) : "", "\n" );
1633         msg( "log,mail", "Error messages:\n", $msgs )
1634                 if $msgs;
1635
1636         # If "permission denied" was among the errors, test if the incoming is
1637         # writable at all.
1638         if ($msgs =~ /(permission denied|read-?only file)/i) {
1639                 if (!check_incoming_writable()) {
1640                         msg( "log,mail", "(The incoming directory seems to be ",
1641                                              "unwritable.)\n" );
1642                 }
1643         }
1644
1645         # remove bad files or an incomplete upload on target
1646         if ($conf::upload_method eq "ssh") {
1647                 ssh_cmd( "rm -f @files" );
1648         }
1649         elsif ($conf::upload_method eq "ftp") {
1650                 my $file;
1651                 foreach $file (@files) {
1652                         my ($rv, $err);
1653                         ($rv, $err) = ftp_cmd( "delete", $file );
1654                         msg( "log", "Can't delete $file on target:\n$err" )
1655                                 if $err;
1656                 }
1657         }
1658         else {
1659                 my @tfiles = map { "$main::current_targetdir/$_" } @files;
1660                 debug( "executing unlink(@tfiles)" );
1661                 rm( @tfiles );
1662         }
1663         $main::dstat = "c";
1664         write_status_file() if $conf::statusdelay;
1665         return 0;
1666 }
1667
1668 #
1669 # check if a file is correctly signed with PGP
1670 #
1671 sub pgp_check($) {
1672         my $file = shift;
1673         my $output = "";
1674         my $signator;
1675         my $found = 0;
1676         my $stat;
1677         local( *PIPE );
1678
1679         $stat = 1;
1680         if (-x $conf::gpg) {
1681                 debug( "executing $conf::gpg --no-options --batch ".
1682                    "--no-default-keyring --always-trust ".
1683                    "--keyring ". join (" --keyring ",@conf::keyrings).
1684                    " --verify '$file'" );
1685                 if (!open( PIPE, "$conf::gpg --no-options --batch ".
1686                    "--no-default-keyring --always-trust ".
1687                    "--keyring " . join (" --keyring ",@conf::keyrings).
1688                    " --verify '$file'".
1689                    " 2>&1 |" )) {
1690                         msg( "log", "Can't open pipe to $conf::gpg: $!\n" );
1691                         return "LOCAL ERROR";
1692                 }
1693                 $output .= $_ while( <PIPE> );
1694                 close( PIPE );
1695                 $stat = $?;
1696         }
1697
1698         if ($stat) {
1699                 msg( "log,mail", "GnuPG signature check failed on $file\n" );
1700                 msg( "mail", $output );
1701                 msg( "log,mail", "(Exit status ", $stat >> 8, ")\n" );
1702                 return "";
1703         }
1704
1705         $output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im;
1706         ($signator = $3) ||= "unknown signator";
1707         if ($conf::debug) {
1708                 debug( "GnuPG signature ok (by $signator)" );
1709         }
1710         return $signator;
1711 }
1712
1713
1714 # ---------------------------------------------------------------------------
1715 #                                                         the status daemon
1716 # ---------------------------------------------------------------------------
1717
1718 #
1719 # fork a subprocess that watches the 'status' FIFO
1720 #
1721 # that process blocks until someone opens the FIFO, then sends a
1722 # signal (SIGUSR1) to the main process, expects
1723 #
1724 sub fork_statusd() {
1725         my $statusd_pid;
1726         my $main_pid = $$;
1727         my $errs;
1728         local( *STATFIFO );
1729
1730         $statusd_pid = open( STATUSD, "|-" );
1731         die "cannot fork: $!\n" if !defined( $statusd_pid );
1732         # parent just returns
1733         if ($statusd_pid) {
1734                 msg( "log", "forked status daemon (pid $statusd_pid)\n" );
1735                 return $statusd_pid;
1736         }
1737         # child: the status FIFO daemon
1738
1739         # ignore SIGPIPE here, in case some closes the FIFO without completely
1740         # reading it
1741         $SIG{"PIPE"} = "IGNORE";
1742         # also ignore SIGCLD, we don't want to inherit the restart-statusd handler
1743         # from our parent
1744         $SIG{"CHLD"} = "DEFAULT";
1745
1746         rm( $conf::statusfile );
1747         $errs = `$conf::mkfifo $conf::statusfile`;
1748         die "$main::progname: cannot create named pipe $conf::statusfile: $errs"
1749                 if $?;
1750         chmod( 0644, $conf::statusfile )
1751                 or die "Cannot set modes of $conf::statusfile: $!\n";
1752
1753         # close log file, so that log rotating works
1754         close( LOG );
1755         close( STDOUT );
1756         close( STDERR );
1757
1758         while( 1 ) {
1759                 my( $status, $mup, $incw, $ds, $next_run, $last_ping, $currch, $l );
1760
1761                 # open the FIFO for writing; this blocks until someone (probably ftpd)
1762                 # opens it for reading
1763                 open( STATFIFO, ">$conf::statusfile" )
1764                         or die "Cannot open $conf::statusfile\n";
1765                 select( STATFIFO );
1766                 # tell main daemon to send us status infos
1767                 kill( $main::signo{"USR1"}, $main_pid );
1768
1769                 # get the infos from stdin; must loop until enough bytes received!
1770                 my $expect_len = 3 + 2*STATNUM_LEN + STATSTR_LEN;
1771                 for( $status = ""; ($l = length($status)) < $expect_len; ) {
1772                         sysread( STDIN, $status, $expect_len-$l, $l );
1773                 }
1774
1775                 # disassemble the status byte stream
1776                 my $pos = 0;
1777                 foreach ( [ mup => 1 ], [ incw => 1 ], [ ds => 1 ],
1778                                   [ next_run => STATNUM_LEN ], [ last_ping => STATNUM_LEN ],
1779                                   [ currch => STATSTR_LEN ] ) {
1780                         eval "\$$_->[0] = substr( \$status, $pos, $_->[1] );";
1781                         $pos += $_->[1];
1782                 }
1783                 $currch =~ s/\n+//g;
1784
1785                 print_status( $mup, $incw, $ds, $next_run, $last_ping, $currch );
1786                 close( STATFIFO );
1787
1788                 # This sleep is necessary so that we can't reopen the FIFO
1789                 # immediately, in case the reader hasn't closed it yet if we get to
1790                 # the open again. Is there a better solution for this??
1791                 sleep 1;
1792         }
1793 }
1794
1795 #
1796 # update the status file, in case we use a plain file and not a FIFO
1797 #
1798 sub write_status_file() {
1799
1800         return if !$conf::statusfile;
1801
1802         open( STATFILE, ">$conf::statusfile" ) or
1803                 (msg( "log", "Could not open $conf::statusfile: $!\n" ), return);
1804         my $oldsel = select( STATFILE );
1805
1806         print_status( $main::target_up, $main::incoming_writable, $main::dstat,
1807                                   $main::next_run, $main::last_ping_time,
1808                                   $main::current_changes );
1809
1810         select( $oldsel );
1811         close( STATFILE );
1812 }
1813
1814 sub print_status($$$$$$) {
1815         my $mup = shift;
1816         my $incw = shift;
1817         my $ds = shift;
1818         my $next_run = shift;
1819         my $last_ping = shift;
1820         my $currch = shift;
1821         my $approx;
1822         my $version;
1823
1824         ($version = 'Release: 0.9 $Revision: 1.51 $') =~ s/\$ ?//g;
1825         print "debianqueued $version\n";
1826
1827         $approx = $conf::statusdelay ? "approx. " : "";
1828
1829         if ($mup eq "0") {
1830                 print "$conf::target is down, queue pausing\n";
1831                 return;
1832         }
1833         elsif ($conf::upload_method ne "copy") {
1834                 print "$conf::target seems to be up, last ping $approx",
1835                           print_time(time-$last_ping), " ago\n";
1836         }
1837
1838         if ($incw eq "0") {
1839                 print "The incoming directory is not writable, queue pausing\n";
1840                 return;
1841         }
1842
1843         if ($ds eq "i") {
1844                 print "Next queue check in $approx",print_time($next_run-time),"\n";
1845                 return;
1846         }
1847         elsif ($ds eq "c") {
1848                 print "Checking queue directory\n";
1849         }
1850         elsif ($ds eq "u") {
1851                 print "Uploading to $conf::target\n";
1852         }
1853         else {
1854                 print "Bad status data from daemon: \"$mup$incw$ds\"\n";
1855                 return;
1856         }
1857
1858         print "Current job is $currch\n" if $currch;
1859 }
1860
1861 #
1862 # format a number for sending to statusd (fixed length STATNUM_LEN)
1863 #
1864 sub format_status_num(\$$) {
1865         my $varref = shift;
1866         my $num = shift;
1867
1868         $$varref = sprintf "%".STATNUM_LEN."d", $num;
1869 }
1870
1871 #
1872 # format a string for sending to statusd (fixed length STATSTR_LEN)
1873 #
1874 sub format_status_str(\$$) {
1875         my $varref = shift;
1876         my $str = shift;
1877
1878         $$varref = substr( $str, 0, STATSTR_LEN );
1879         $$varref .= "\n" x (STATSTR_LEN - length($$varref));
1880 }
1881
1882 #
1883 # send a status string to the status daemon
1884 #
1885 # Avoid all operations that could call malloc() here! Most libc
1886 # implementations aren't reentrant, so we may not call it from a
1887 # signal handler. So use only already-defined variables.
1888 #
1889 sub send_status() {
1890     local $! = 0; # preserve errno
1891
1892         # re-setup handler, in case we have broken SysV signals
1893         $SIG{"USR1"} = \&send_status;
1894
1895         syswrite( STATUSD, $main::target_up, 1 );
1896         syswrite( STATUSD, $main::incoming_writable, 1 );
1897         syswrite( STATUSD, $main::dstat, 1 );
1898         syswrite( STATUSD, $main::next_run, STATNUM_LEN );
1899         syswrite( STATUSD, $main::last_ping_time, STATNUM_LEN );
1900         syswrite( STATUSD, $main::current_changes, STATSTR_LEN );
1901 }
1902
1903
1904 # ---------------------------------------------------------------------------
1905 #                                                           FTP functions
1906 # ---------------------------------------------------------------------------
1907
1908 #
1909 # open FTP connection to target host if not already open
1910 #
1911 sub ftp_open() {
1912
1913         if ($main::FTP_chan) {
1914                 # is already open, but might have timed out; test with a cwd
1915                 return $main::FTP_chan if $main::FTP_chan->cwd( $main::current_targetdir );
1916                 # cwd didn't work, channel is closed, try to reopen it
1917                 $main::FTP_chan = undef;
1918         }
1919
1920         if (!($main::FTP_chan = Net::FTP->new( $conf::target,
1921                                                                                    Debug => $conf::ftpdebug,
1922                                                                                    Timeout => $conf::ftptimeout ))) {
1923                 msg( "log,mail", "Cannot open FTP server $conf::target\n" );
1924                 goto err;
1925         }
1926         if (!$main::FTP_chan->login()) {
1927                 msg( "log,mail", "Anonymous login on FTP server $conf::target failed\n" );
1928                 goto err;
1929         }
1930         if (!$main::FTP_chan->binary()) {
1931                 msg( "log,mail", "Can't set binary FTP mode on $conf::target\n" );
1932                 goto err;
1933         }
1934         if (!$main::FTP_chan->cwd( $main::current_targetdir )) {
1935                 msg( "log,mail", "Can't cd to $main::current_targetdir on $conf::target\n" );
1936                 goto err;
1937         }
1938         debug( "opened FTP channel to $conf::target" );
1939         return 1;
1940
1941   err:
1942         $main::FTP_chan = undef;
1943         return 0;
1944 }
1945
1946 sub ftp_cmd($@) {
1947         my $cmd = shift;
1948         my ($rv, $err);
1949         my $direct_resp_cmd = ($cmd eq "quot");
1950
1951         debug( "executing FTP::$cmd(".join(", ",@_).")" );
1952         $SIG{"ALRM"} = sub { die "timeout in FTP::$cmd\n" } ;
1953         alarm( $conf::remote_timeout );
1954         eval { $rv = $main::FTP_chan->$cmd( @_ ); };
1955         alarm( 0 );
1956         $err = "";
1957         $rv = (ftp_code() =~ /^2/) ? 1 : 0 if $direct_resp_cmd;
1958         if ($@) {
1959                 $err = $@;
1960                 undef $rv;
1961         }
1962         elsif (!$rv) {
1963                 $err = ftp_response();
1964         }
1965         return ($rv, $err);
1966 }
1967
1968 sub ftp_close() {
1969         if ($main::FTP_chan) {
1970                 $main::FTP_chan->quit();
1971                 $main::FTP_chan = undef;
1972         }
1973         return 1;
1974 }
1975
1976 sub ftp_response() {
1977         return join( '', @{${*$main::FTP_chan}{'net_cmd_resp'}} );
1978 }
1979
1980 sub ftp_code() {
1981         return ${*$main::FTP_chan}{'net_cmd_code'};
1982 }
1983
1984 sub ftp_error() {
1985         my $code = ftp_code();
1986         return ($code =~ /^[45]/) ? 1 : 0;
1987 }
1988
1989 # ---------------------------------------------------------------------------
1990 #                                                         utility functions
1991 # ---------------------------------------------------------------------------
1992
1993 sub ssh_cmd($) {
1994         my $cmd = shift;
1995         my ($msg, $stat);
1996
1997         my $ecmd = "$conf::ssh $conf::ssh_options $conf::target ".
1998                            "-l $conf::targetlogin \'cd $main::current_targetdir; $cmd\'";
1999         debug( "executing $ecmd" );
2000         $SIG{"ALRM"} = sub { die "timeout in ssh command\n" } ;
2001         alarm( $conf::remote_timeout );
2002         eval { $msg = `$ecmd 2>&1`; };
2003         alarm( 0 );
2004         if ($@) {
2005                 $msg = $@;
2006                 $stat = 1;
2007         }
2008         else {
2009                 $stat = $?;
2010         }
2011         return ($msg, $stat);
2012 }
2013
2014 sub scp_cmd(@) {
2015         my ($msg, $stat);
2016
2017         my $ecmd = "$conf::scp $conf::ssh_options @_ ".
2018                            "$conf::targetlogin\@$conf::target:$main::current_targetdir";
2019         debug( "executing $ecmd" );
2020         $SIG{"ALRM"} = sub { die "timeout in scp\n" } ;
2021         alarm( $conf::remote_timeout );
2022         eval { $msg = `$ecmd 2>&1`; };
2023         alarm( 0 );
2024         if ($@) {
2025                 $msg = $@;
2026                 $stat = 1;
2027         }
2028         else {
2029                 $stat = $?;
2030         }
2031         return ($msg, $stat);
2032 }
2033
2034 sub local_cmd($;$) {
2035         my $cmd = shift;
2036         my $nocd = shift;
2037         my ($msg, $stat);
2038
2039         my $ecmd = ($nocd ? "" : "cd $main::current_targetdir; ") . $cmd;
2040         debug( "executing $ecmd" );
2041         $msg = `($ecmd) 2>&1`;
2042         $stat = $?;
2043         return ($msg, $stat);
2044
2045 }
2046
2047 #
2048 # check if target is alive (code stolen from Net::Ping.pm)
2049 #
2050 sub check_alive(;$) {
2051     my $timeout = shift;
2052     my( $saddr, $ret, $target_ip );
2053     local( *PINGSOCK );
2054
2055         if ($conf::upload_method eq "copy") {
2056                 format_status_num( $main::last_ping_time, time );
2057                 $main::target_up = 1;
2058                 return;
2059         }
2060
2061     $timeout ||= 30;
2062
2063         if (!($target_ip = (gethostbyname($conf::target))[4])) {
2064                 msg( "log", "Cannot get IP address of $conf::target\n" );
2065                 $ret = 0;
2066                 goto out;
2067         }
2068     $saddr = pack( 'S n a4 x8', AF_INET, $main::echo_port, $target_ip );
2069     $SIG{'ALRM'} = sub { die } ;
2070     alarm( $timeout );
2071
2072         $ret = $main::tcp_proto; # avoid warnings about unused variable
2073     $ret = 0;
2074     eval <<'EOM' ;
2075     return unless socket( PINGSOCK, PF_INET, SOCK_STREAM, $main::tcp_proto );
2076     return unless connect( PINGSOCK, $saddr );
2077     $ret = 1;
2078 EOM
2079     alarm( 0 );
2080     close( PINGSOCK );
2081         msg( "log", "pinging $conf::target: " . ($ret ? "ok" : "down") . "\n" );
2082   out:
2083         $main::target_up = $ret ? "1" : "0";
2084         format_status_num( $main::last_ping_time, time );
2085         write_status_file() if $conf::statusdelay;
2086 }
2087
2088 #
2089 # check if incoming dir on target is writable
2090 #
2091 sub check_incoming_writable() {
2092         my $testfile = ".debianqueued-testfile";
2093         my ($msg, $stat);
2094
2095         if ($conf::upload_method eq "ssh") {
2096                 ($msg, $stat) = ssh_cmd( "rm -f $testfile; touch $testfile; ".
2097                                                                  "rm -f $testfile" );
2098         }
2099         elsif ($conf::upload_method eq "ftp") {
2100                 my $file = "junk-for-writable-test-".format_time();
2101                 $file =~ s/[ :.]/-/g;
2102                 local( *F );
2103                 open( F, ">$file" ); close( F );
2104                 my $rv;
2105                 ($rv, $msg) = ftp_cmd( "put", $file );
2106                 $stat = 0;
2107                 $msg = "" if !defined $msg;
2108                 unlink $file;
2109                 ftp_cmd( "delete", $file );
2110         }
2111         elsif ($conf::upload_method eq "copy") {
2112                 ($msg, $stat) = local_cmd( "rm -f $testfile; touch $testfile; ".
2113                                                                    "rm -f $testfile" );
2114         }
2115         chomp( $msg );
2116         debug( "exit status: $stat, output was: $msg" );
2117
2118         if (!$stat) {
2119                 # change incoming_writable only if ssh didn't return an error
2120                 $main::incoming_writable =
2121                         ($msg =~ /(permission denied|read-?only file|cannot create)/i) ? "0":"1";
2122         }
2123         else {
2124                 debug( "local error, keeping old status" );
2125         }
2126         debug( "incoming_writable = $main::incoming_writable" );
2127         write_status_file() if $conf::statusdelay;
2128         return $main::incoming_writable;
2129 }
2130
2131 #
2132 # remove a list of files, log failing ones
2133 #
2134 sub rm(@) {
2135         my $done = 0;
2136
2137         foreach ( @_ ) {
2138                 (unlink $_ and ++$done)
2139                         or $! == ENOENT or msg( "log", "Could not delete $_: $!\n" );
2140         }
2141         return $done;
2142 }
2143
2144 #
2145 # get md5 checksum of a file
2146 #
2147 sub md5sum($) {
2148         my $file = shift;
2149         my $line;
2150
2151         chomp( $line = `$conf::md5sum $file` );
2152         debug( "md5sum($file): ", $? ? "exit status $?" :
2153                                       $line =~ /^(\S+)/ ? $1 : "match failed" );
2154         return $? ? "" : $line =~ /^(\S+)/ ? $1 : "";
2155 }
2156
2157 #
2158 # check if a file probably belongs to a Debian upload
2159 #
2160 sub is_debian_file($) {
2161         my $file = shift;
2162         return $file =~ /\.(deb|dsc|(diff|tar)\.gz)$/ &&
2163                    $file !~ /\.orig\.tar\.gz/;
2164 }
2165
2166 #
2167 # try to extract maintainer email address from some a non-.changes file
2168 # return "" if not possible
2169 #
2170 sub get_maintainer($) {
2171         my $file = shift;
2172         my $maintainer = "";
2173         local( *F );
2174
2175         if ($file =~ /\.diff\.gz$/) {
2176                 # parse a diff
2177                 open( F, "$conf::gzip -dc '$file' 2>/dev/null |" ) or return "";
2178                 while( <F> ) {
2179                         # look for header line of a file */debian/control
2180                         last if m,^\+\+\+\s+[^/]+/debian/control(\s+|$),;
2181                 }
2182                 while( <F> ) {
2183                         last if /^---/; # end of control file patch, no Maintainer: found
2184                         # inside control file patch look for Maintainer: field
2185                         $maintainer = $1, last if /^\+Maintainer:\s*(.*)$/i;
2186                 }
2187                 while( <F> ) { } # read to end of file to avoid broken pipe
2188                 close( F ) or return "";
2189         }
2190         elsif ($file =~ /\.(deb|dsc|tar\.gz)$/) {
2191                 if ($file =~ /\.deb$/ && $conf::ar) {
2192                         # extract control.tar.gz from .deb with ar, then let tar extract
2193                         # the control file itself
2194                         open( F, "($conf::ar p '$file' control.tar.gz | ".
2195                                      "$conf::tar -xOf - ".
2196                                      "--use-compress-program $conf::gzip ".
2197                                      "control) 2>/dev/null |" )
2198                                 or return "";
2199                 }
2200                 elsif ($file =~ /\.dsc$/) {
2201                         # just do a plain grep
2202                         debug( "get_maint: .dsc, no cmd" );
2203                         open( F, "<$file" ) or return "";
2204                 }
2205                 elsif ($file =~ /\.tar\.gz$/) {
2206                         # let tar extract a file */debian/control
2207                         open(F, "$conf::tar -xOf '$file' ".
2208                                     "--use-compress-program $conf::gzip ".
2209                                     "\\*/debian/control 2>&1 |")
2210                                 or return "";
2211                 }
2212                 else {
2213                         return "";
2214                 }
2215                 while( <F> ) {
2216                         $maintainer = $1, last if /^Maintainer:\s*(.*)$/i;
2217                 }
2218                 close( F ) or return "";
2219         }
2220
2221         return $maintainer;
2222 }
2223
2224 #
2225 # return a pattern that matches all files that probably belong to one job
2226 #
2227 sub debian_file_stem($) {
2228         my $file = shift;
2229         my( $pkg, $version );
2230
2231         # strip file suffix
2232         $file =~ s,\.(deb|dsc|changes|(orig\.)?tar\.gz|diff\.gz)$,,;
2233         # if not is *_* (name_version), can't derive a stem and return just
2234         # the file's name
2235         return $file if !($file =~ /^([^_]+)_([^_]+)/);
2236         ($pkg, $version) = ($1, $2);
2237         # strip Debian revision from version
2238         $version =~ s/^(.*)-[\d.+-]+$/$1/;
2239
2240         return "${pkg}_${version}*";
2241 }
2242
2243 #
2244 # output a messages to several destinations
2245 #
2246 # first arg is a comma-separated list of destinations; valid are "log"
2247 # and "mail"; rest is stuff to be printed, just as with print
2248 #
2249 sub msg($@) {
2250         my @dest = split( ',', shift );
2251
2252         if (grep /log/, @dest ) {
2253                 my $now = format_time();
2254                 print LOG "$now ", @_;
2255         }
2256
2257         if (grep /mail/, @dest ) {
2258                 $main::mail_text .= join( '', @_ );
2259         }
2260 }
2261
2262 #
2263 # print a debug messages, if $debug is true
2264 #
2265 sub debug(@) {
2266         return if !$conf::debug;
2267         my $now = format_time();
2268         print LOG "$now DEBUG ", @_, "\n";
2269 }
2270
2271 #
2272 # intialize the "mail" destination of msg() (this clears text,
2273 # address, subject, ...)
2274 #
2275 sub init_mail(;$) {
2276         my $file = shift;
2277
2278         $main::mail_addr = "";
2279         $main::mail_text = "";
2280         %main::packages  = ();
2281         $main::mail_subject = $file ? "Processing of $file" : "";
2282 }
2283
2284 #
2285 # finalize mail to be sent from msg(): check if something present, and
2286 # then send out
2287 #
2288 sub finish_mail() {
2289
2290         debug( "No mail for $main::mail_addr" )
2291                 if $main::mail_addr && !$main::mail_text;
2292         return unless $main::mail_addr && $main::mail_text;
2293
2294         if (!send_mail($main::mail_addr, $main::mail_subject, $main::mail_text)) {
2295                 # store this mail in memory so it isn't lost if executing sendmail
2296                 # failed.
2297                 push( @main::stored_mails, { addr    => $main::mail_addr,
2298                                                                          subject => $main::mail_subject,
2299                                                                          text    => $main::mail_text } );
2300         }
2301         init_mail();
2302
2303         # try to send out stored mails
2304         my $mailref;
2305         while( $mailref = shift(@main::stored_mails) ) {
2306                 if (!send_mail( $mailref->{'addr'}, $mailref->{'subject'},
2307                                             $mailref->{'text'} )) {
2308                         unshift( @main::stored_mails, $mailref );
2309                         last;
2310                 }
2311         }
2312 }
2313
2314 #
2315 # send one mail
2316 #
2317 sub send_mail($$$) {
2318         my $addr = shift;
2319         my $subject = shift;
2320         my $text = shift;
2321
2322         my $package = keys %main::packages ? join(' ', keys %main::packages) : "";
2323
2324         use Email::Send;
2325
2326         unless (defined($Email::Send::Sendmail::SENDMAIL)) {
2327                 $Email::Send::Sendmail::SENDMAIL = $conf::mail;
2328         }
2329
2330         my $date = sprintf "%s", strftime("%a, %d %b %Y %T %z", (localtime(time)));
2331         my $message = <<__MESSAGE__;
2332 To: $addr
2333 From: Archive Administrator <dak\@ftp-master.debian.org>
2334 Subject: $subject
2335 Date: $date
2336 X-Debian: DAK
2337 __MESSAGE__
2338
2339         if (length $package) {
2340                 $message .= "X-Debian-Package: $package\n";
2341         }
2342
2343         $message .= "\n$text";
2344         $message .= "\nGreetings,\n\n\tYour Debian queue daemon\n";
2345
2346         my $mail = Email::Send->new;
2347         for ( qw[Sendmail SMTP] ) {
2348                 $mail->mailer($_) and last if $mail->mailer_available($_);
2349         }
2350
2351         my $ret = $mail->send($message);
2352         if ($ret && $ret !~ /Message sent|success/) {
2353                 return 0;
2354         }
2355
2356         return 1;
2357 }
2358
2359 #
2360 # try to find a mail address for a name in the keyrings
2361 #
2362 sub try_to_get_mail_addr($$) {
2363         my $name = shift;
2364         my $listref = shift;
2365
2366         @$listref = ();
2367         open( F, "$conf::gpg --no-options --batch --no-default-keyring ".
2368                 "--always-trust --keyring ".
2369                 join (" --keyring ",@conf::keyrings).
2370                 " --list-keys |" )
2371                 or return "";
2372         while( <F> ) {
2373                 if (/^pub / && / $name /) {
2374                         /<([^>]*)>/;
2375                         push( @$listref, $1 );
2376                 }
2377         }
2378         close( F );
2379
2380         return (@$listref >= 1) ? $listref->[0] : "";
2381 }
2382
2383 #
2384 # return current time as string
2385 #
2386 sub format_time() {
2387         my $t;
2388
2389         # omit weekday and year for brevity
2390         ($t = localtime) =~ /^\w+\s(.*)\s\d+$/;
2391         return $1;
2392 }
2393
2394 sub print_time($) {
2395         my $secs = shift;
2396         my $hours = int($secs/(60*60));
2397
2398         $secs -= $hours*60*60;
2399         return sprintf "%d:%02d:%02d", $hours, int($secs/60), $secs % 60;
2400 }
2401
2402 #
2403 # block some signals during queue processing
2404 #
2405 # This is just to avoid data inconsistency or uploads being aborted in the
2406 # middle. Only "soft" signals are blocked, i.e. SIGINT and SIGTERM, try harder
2407 # ones if you really want to kill the daemon at once.
2408 #
2409 sub block_signals() {
2410         POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset );
2411 }
2412
2413 sub unblock_signals() {
2414         POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset );
2415 }
2416
2417 #
2418 # process SIGHUP: close log file and reopen it (for logfile cycling)
2419 #
2420 sub close_log($) {
2421         close( LOG );
2422         close( STDOUT );
2423         close( STDERR );
2424
2425         open( LOG, ">>$conf::logfile" )
2426                 or die "Cannot open my logfile $conf::logfile: $!\n";
2427         chmod( 0644, $conf::logfile )
2428                 or msg( "log", "Cannot set modes of $conf::logfile: $!\n" );
2429         select( (select(LOG), $| = 1)[0] );
2430
2431         open( STDOUT, ">&LOG" )
2432                 or msg( "log", "$main::progname: Can't redirect stdout to ".
2433                             "$conf::logfile: $!\n" );
2434         open( STDERR, ">&LOG" )
2435                 or msg( "log", "$main::progname: Can't redirect stderr to ".
2436                             "$conf::logfile: $!\n" );
2437         msg( "log", "Restart after SIGHUP\n" );
2438 }
2439
2440 #
2441 # process SIGCHLD: check if it was our statusd process
2442 #
2443 sub kid_died($) {
2444         my $pid;
2445
2446         # reap statusd, so that it's no zombie when we try to kill(0) it
2447         waitpid( $main::statusd_pid, WNOHANG );
2448
2449 # Uncomment the following line if your Perl uses unreliable System V signal
2450 # (i.e. if handlers reset to default if the signal is delivered).
2451 # (Unfortunately, the re-setup can't be done in any case, since on some
2452 # systems this will cause the SIGCHLD to be delivered again if there are
2453 # still unreaped children :-(( )
2454
2455 #        $SIG{"CHLD"} = \&kid_died; # resetup handler for SysV
2456 }
2457
2458 sub restart_statusd() {
2459         # restart statusd if it died
2460         if (!kill( 0, $main::statusd_pid)) {
2461                 close( STATUSD ); # close out pipe end
2462                 $main::statusd_pid = fork_statusd();
2463         }
2464 }
2465
2466 #
2467 # process a fatal signal: cleanup and exit
2468 #
2469 sub fatal_signal($) {
2470         my $signame = shift;
2471         my $sig;
2472
2473         # avoid recursions of fatal_signal in case of BSD signals
2474         foreach $sig ( qw( ILL ABRT BUS FPE SEGV PIPE ) ) {
2475                 $SIG{$sig} = "DEFAULT";
2476         }
2477
2478         if ($$ == $main::maind_pid) {
2479                 # only the main daemon should do this
2480                 kill( $main::signo{"TERM"}, $main::statusd_pid )
2481                         if defined $main::statusd_pid;
2482                 unlink( $conf::statusfile, $conf::pidfile );
2483         }
2484         msg( "log", "Caught SIG$signame -- exiting (pid $$)\n" );
2485         exit 1;
2486 }
2487
2488
2489 # Local Variables:
2490 #  tab-width: 4
2491 #  fill-column: 78
2492 # End: