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                                                 if (-f $file) {
1331                                                         push (@thesefiles, $file);
1332                                                 }
1333                                     }
1334                                         if ($file =~ m/\.changes$/ &&  $conf::upload_method eq "copy") {
1335                                                 for ( my($adelay)=0; $adelay <= $conf::max_delayed; $adelay++ ) {
1336                                                         my($dir) = sprintf( "$conf::targetdir_delayed",$adelay );
1337                                                         if (-f "$dir/$file") {
1338                                                                 push (@thesefiles, "$dir/$file");
1339                                                                 push (@thesefiles, map( "$dir/$_",get_filelist_from_known_good_changes("$dir/$file")));
1340                                                         }
1341                                                 }
1342                                         }
1343                                         if (!@thesefiles) {
1344                                                 msg( "mail,log", "No file found: $file\n" );
1345                                         }
1346                                         push (@files, @thesefiles);
1347                                 }
1348                         }
1349                         if (!@files) {
1350                                 msg( "mail,log", "No files to delete\n" );
1351                         }
1352                         else {
1353                                 @removed = ();
1354                                 foreach $file ( @files ) {
1355                                         if (!-f $file) {
1356                                                 msg( "mail,log", "$file: no such file\n" );
1357                                         }
1358                                         elsif ($file =~ /$conf::keep_files/) {
1359                                                 msg( "mail,log", "$file is protected, cannot ".
1360                                                          "remove\n" );
1361                                         }
1362                                         elsif (!unlink( $file )) {
1363                                                 msg( "mail,log", "$file: rm: $!\n" );
1364                                         }
1365                                         else {
1366                                                 push( @removed, $file );
1367                                         }
1368                                 }
1369                                 msg( "mail,log", "Files removed: @removed\n" ) if @removed;
1370                         }
1371                 }
1372                 elsif ($word[0] eq "mv") {
1373                         if (@word != 3) {
1374                                 msg( "mail,log", "Wrong number of arguments\n" );
1375                         }
1376                         elsif ($word[1] =~ m,/, || $word[1] !~ m/\.changes/) {
1377                                 msg( "mail,log", "$word[1]: filename may not contain slashes\n" );
1378                         }
1379                         elsif (! (($target_delay) = $word[2] =~ m,^([0-9]+)-day$,) || $target_delay > $conf::max_delayed) {
1380                                 msg( "mail,log", "$word[2]: target must be #-day with # between 0 and $conf::max_delayed\n");
1381                         }
1382                         elsif ($word[1] =~ /$conf::keep_files/) {
1383                                 msg( "mail,log", "$word[1] is protected, cannot rename\n" );
1384                         }
1385                         else {
1386                                 my($adelay);
1387                                 for ( $adelay=0; $adelay <= $conf::max_delayed && ! -f (sprintf( "$conf::targetdir_delayed",$adelay )."/$word[1]"); $adelay++ ) {
1388                                 }
1389                                 if ( $adelay > $conf::max_delayed) {
1390                                         msg( "mail,log", "$word[1] not found\n" );
1391                                 }
1392                                 elsif ($adelay == $target_delay) {
1393                                         msg( "mail,log", "$word[1] already is in $word[2]\n" );
1394                                 }
1395                                 else {
1396                                         my(@thesefiles);
1397                                         my($dir) = sprintf( "$conf::targetdir_delayed",$adelay );
1398                                         my($target_dir) = sprintf( "$conf::targetdir_delayed",$target_delay );
1399                                         push (@thesefiles, $word[1]);
1400                                         push (@thesefiles, get_filelist_from_known_good_changes("$dir/$word[1]"));
1401                                         for my $afile(@thesefiles) {
1402                                                 if (! rename "$dir/$afile","$target_dir/$afile") {
1403                                                         msg( "mail,log", "rename: $!\n" );
1404                                                 }
1405                                                 else {
1406                                                         msg( "mail,log", "$afile moved to $target_delay-day\n" );
1407                                                 }
1408                                         }
1409                                 }
1410                         }
1411                 }
1412                 else {
1413                         msg( "mail,log", "unknown command $word[0]\n" );
1414                 }
1415         }
1416         rm( $commands );
1417         msg( "log", "-- End of $main::current_incoming_short/$commands processing\n" );
1418 }
1419
1420 sub age_delayed_queues() {
1421         for ( my($adelay)=0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
1422                 my($dir) = sprintf( "$conf::targetdir_delayed",$adelay );
1423                 my($target_dir);
1424                 if ($adelay == 0) {
1425                     $target_dir = $conf::targetdir;
1426                 }
1427                 else {
1428                         $target_dir = sprintf( "$conf::targetdir_delayed",$adelay-1 );
1429                 }
1430                 for my $achanges (<$dir/*.changes>) {
1431                         my $mtime = (stat($achanges))[9];
1432                         if ($mtime + 24*60*60 <= time) {
1433                                 utime undef,undef,($achanges);
1434                                 my @thesefiles = ($achanges =~ m,.*/([^/]*),);
1435                                 push (@thesefiles, get_filelist_from_known_good_changes($achanges));
1436                                 for my $afile(@thesefiles) {
1437                                         if (! rename "$dir/$afile","$target_dir/$afile") {
1438                                                 msg( "log", "rename: $!\n" );
1439                                         }
1440                                         else {
1441                                                 msg( "log", "$afile moved to $target_dir\n" );
1442                                         }
1443                                 }
1444                         }
1445                 }
1446         }
1447 }
1448
1449 #
1450 # check if a file is already on target
1451 #
1452 sub is_on_target($\@) {
1453         my $file = shift;
1454         my $filelist = shift;
1455         my $msg;
1456         my $stat;
1457
1458         if ($conf::upload_method eq "ssh") {
1459                 ($msg, $stat) = ssh_cmd( "ls -l $file" );
1460         }
1461         elsif ($conf::upload_method eq "ftp") {
1462                 my $err;
1463                 ($msg, $err) = ftp_cmd( "dir", $file );
1464                 if ($err) {
1465                         $stat = 1;
1466                         $msg = $err;
1467                 }
1468                 elsif (!$msg) {
1469                         $stat = 1;
1470                         $msg = "ls: no such file\n";
1471                 }
1472                 else {
1473                         $stat = 0;
1474                         $msg = join( "\n", @$msg );
1475                 }
1476         }
1477         else {
1478                 my @allfiles = ($file);
1479                 push ( @allfiles, @$filelist);
1480                 $stat = 1;
1481                 $msg = "no such file";
1482                 for my $afile(@allfiles) {
1483                         if (-f "$conf::incoming/$afile") {
1484                                 $stat = 0;
1485                     $msg = "$afile";
1486                         }
1487                 }
1488                 for ( my($adelay)=0 ; $adelay <= $conf::max_delayed && $stat ; $adelay++ ) {
1489                         for my $afile(@allfiles) {
1490                                 if (-f (sprintf( "$conf::targetdir_delayed",$adelay )."/$afile")) {
1491                                         $stat = 0;
1492                                         $msg = sprintf( "%d-day",$adelay )."/$afile";
1493                                 }
1494                         }
1495                 }
1496         }
1497         chomp( $msg );
1498         debug( "exit status: $stat, output was: $msg" );
1499
1500         return "" if $stat && $msg =~ /no such file/i; # file not present
1501         msg( "log", "strange ls -l output on target:\n", $msg ), return ""
1502                 if $stat || $@; # some other error, but still try to upload
1503
1504         # ls -l returned 0 -> file already there
1505         $msg =~ s/\s\s+/ /g; # make multiple spaces into one, to save space
1506         return $msg;
1507 }
1508
1509 #
1510 # copy a list of files to target
1511 #
1512 sub copy_to_target(@) {
1513         my @files = @_;
1514         my( @md5sum, @expected_files, $sum, $name, $msgs, $stat );
1515
1516         $main::dstat = "u";
1517         write_status_file() if $conf::statusdelay;
1518
1519         # copy the files
1520         if ($conf::upload_method eq "ssh") {
1521                 ($msgs, $stat) = scp_cmd( @files );
1522                 goto err if $stat;
1523         }
1524         elsif ($conf::upload_method eq "ftp") {
1525                 my($rv, $file);
1526                 if (!$main::FTP_chan->cwd( $main::current_targetdir )) {
1527                         msg( "log,mail", "Can't cd to $main::current_targetdir on $conf::target\n" );
1528                         goto err;
1529                 }
1530                 foreach $file (@files) {
1531                         ($rv, $msgs) = ftp_cmd( "put", $file );
1532                         goto err if !$rv;
1533                 }
1534         }
1535         else {
1536                 ($msgs, $stat) = local_cmd( "$conf::cp @files $main::current_targetdir", 'NOCD' );
1537                 goto err if $stat;
1538         }
1539
1540         # check md5sums or sizes on target against our own
1541         my $have_md5sums = 1;
1542         if ($conf::upload_method eq "ssh") {
1543                 ($msgs, $stat) = ssh_cmd( "md5sum @files" );
1544                 goto err if $stat;
1545                 @md5sum = split( "\n", $msgs );
1546         }
1547         elsif ($conf::upload_method eq "ftp") {
1548                 my ($rv, $err, $file);
1549                 foreach $file (@files) {
1550                         ($rv, $err) = ftp_cmd( "quot", "site", "md5sum", $file );
1551                         if ($err) {
1552                                 next if ftp_code() == 550; # file not found
1553                                 if (ftp_code() == 500) { # unimplemented
1554                                         $have_md5sums = 0;
1555                                         goto get_sizes_instead;
1556                                 }
1557                                 $msgs = $err;
1558                                 goto err;
1559                         }
1560                         chomp( my $t = ftp_response() );
1561                         push( @md5sum, $t );
1562                 }
1563                 if (!$have_md5sums) {
1564                   get_sizes_instead:
1565                         foreach $file (@files) {
1566                                 ($rv, $err) = ftp_cmd( "size", $file );
1567                                 if ($err) {
1568                                         next if ftp_code() == 550; # file not found
1569                                         $msgs = $err;
1570                                         goto err;
1571                                 }
1572                                 push( @md5sum, "$rv $file" );
1573                         }
1574                 }
1575         }
1576         else {
1577                 ($msgs, $stat) = local_cmd( "$conf::md5sum @files" );
1578                 goto err if $stat;
1579                 @md5sum = split( "\n", $msgs );
1580         }
1581
1582         @expected_files = @files;
1583         foreach (@md5sum) {
1584                 chomp;
1585                 ($sum,$name) = split;
1586                 next if !grep { $_ eq $name } @files; # a file we didn't upload??
1587                 next if $sum eq "md5sum:"; # looks like an error message
1588                 if (($have_md5sums && $sum ne md5sum( $name )) ||
1589                         (!$have_md5sums && $sum != (-s $name))) {
1590                         msg( "log,mail", "Upload of $name to $conf::target failed ",
1591                                  "(".($have_md5sums ? "md5sum" : "size")." mismatch)\n" );
1592                         goto err;
1593                 }
1594                 # seen that file, remove it from expect list
1595                 @expected_files = map { $_ eq $name ? () : $_ } @expected_files;
1596         }
1597         if (@expected_files) {
1598                 msg( "log,mail", "Failed to upload the files\n" );
1599                 msg( "log,mail", "  ", join( ", ", @expected_files ), "\n" );
1600                 msg( "log,mail", "(Not present on target after upload)\n" );
1601                 goto err;
1602         }
1603
1604         if ($conf::chmod_on_target) {
1605                 # change file's mode explicitly to 644 on target
1606                 if ($conf::upload_method eq "ssh") {
1607                         ($msgs, $stat) = ssh_cmd( "chmod 644 @files" );
1608                         goto err if $stat;
1609                 }
1610                 elsif ($conf::upload_method eq "ftp") {
1611                         my ($rv, $file);
1612                         foreach $file (@files) {
1613                                 ($rv, $msgs) = ftp_cmd( "quot", "site", "chmod", "644", $file );
1614                                 msg( "log", "Can't chmod $file on target:\n$msgs" )
1615                                         if $msgs;
1616                                 goto err if !$rv;
1617                         }
1618                 }
1619                 else {
1620                         ($msgs, $stat) = local_cmd( "$conf::chmod 644 @files" );
1621                         goto err if $stat;
1622                 }
1623         }
1624
1625         $main::dstat = "c";
1626         write_status_file() if $conf::statusdelay;
1627         return 1;
1628
1629   err:
1630         msg( "log,mail", "Upload to $conf::target failed",
1631                  $? ? ", last exit status ".sprintf( "%s", $?>>8 ) : "", "\n" );
1632         msg( "log,mail", "Error messages:\n", $msgs )
1633                 if $msgs;
1634
1635         # If "permission denied" was among the errors, test if the incoming is
1636         # writable at all.
1637         if ($msgs =~ /(permission denied|read-?only file)/i) {
1638                 if (!check_incoming_writable()) {
1639                         msg( "log,mail", "(The incoming directory seems to be ",
1640                                              "unwritable.)\n" );
1641                 }
1642         }
1643
1644         # remove bad files or an incomplete upload on target
1645         if ($conf::upload_method eq "ssh") {
1646                 ssh_cmd( "rm -f @files" );
1647         }
1648         elsif ($conf::upload_method eq "ftp") {
1649                 my $file;
1650                 foreach $file (@files) {
1651                         my ($rv, $err);
1652                         ($rv, $err) = ftp_cmd( "delete", $file );
1653                         msg( "log", "Can't delete $file on target:\n$err" )
1654                                 if $err;
1655                 }
1656         }
1657         else {
1658                 my @tfiles = map { "$main::current_targetdir/$_" } @files;
1659                 debug( "executing unlink(@tfiles)" );
1660                 rm( @tfiles );
1661         }
1662         $main::dstat = "c";
1663         write_status_file() if $conf::statusdelay;
1664         return 0;
1665 }
1666
1667 #
1668 # check if a file is correctly signed with PGP
1669 #
1670 sub pgp_check($) {
1671         my $file = shift;
1672         my $output = "";
1673         my $signator;
1674         my $found = 0;
1675         my $stat;
1676         local( *PIPE );
1677
1678         $stat = 1;
1679         if (-x $conf::gpg) {
1680                 debug( "executing $conf::gpg --no-options --batch ".
1681                    "--no-default-keyring --always-trust ".
1682                    "--keyring ". join (" --keyring ",@conf::keyrings).
1683                    " --verify '$file'" );
1684                 if (!open( PIPE, "$conf::gpg --no-options --batch ".
1685                    "--no-default-keyring --always-trust ".
1686                    "--keyring " . join (" --keyring ",@conf::keyrings).
1687                    " --verify '$file'".
1688                    " 2>&1 |" )) {
1689                         msg( "log", "Can't open pipe to $conf::gpg: $!\n" );
1690                         return "LOCAL ERROR";
1691                 }
1692                 $output .= $_ while( <PIPE> );
1693                 close( PIPE );
1694                 $stat = $?;
1695         }
1696
1697         if ($stat) {
1698                 msg( "log,mail", "GnuPG signature check failed on $file\n" );
1699                 msg( "mail", $output );
1700                 msg( "log,mail", "(Exit status ", $stat >> 8, ")\n" );
1701                 return "";
1702         }
1703
1704         $output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im;
1705         ($signator = $3) ||= "unknown signator";
1706         if ($conf::debug) {
1707                 debug( "GnuPG signature ok (by $signator)" );
1708         }
1709         return $signator;
1710 }
1711
1712
1713 # ---------------------------------------------------------------------------
1714 #                                                         the status daemon
1715 # ---------------------------------------------------------------------------
1716
1717 #
1718 # fork a subprocess that watches the 'status' FIFO
1719 #
1720 # that process blocks until someone opens the FIFO, then sends a
1721 # signal (SIGUSR1) to the main process, expects
1722 #
1723 sub fork_statusd() {
1724         my $statusd_pid;
1725         my $main_pid = $$;
1726         my $errs;
1727         local( *STATFIFO );
1728
1729         $statusd_pid = open( STATUSD, "|-" );
1730         die "cannot fork: $!\n" if !defined( $statusd_pid );
1731         # parent just returns
1732         if ($statusd_pid) {
1733                 msg( "log", "forked status daemon (pid $statusd_pid)\n" );
1734                 return $statusd_pid;
1735         }
1736         # child: the status FIFO daemon
1737
1738         # ignore SIGPIPE here, in case some closes the FIFO without completely
1739         # reading it
1740         $SIG{"PIPE"} = "IGNORE";
1741         # also ignore SIGCLD, we don't want to inherit the restart-statusd handler
1742         # from our parent
1743         $SIG{"CHLD"} = "DEFAULT";
1744
1745         rm( $conf::statusfile );
1746         $errs = `$conf::mkfifo $conf::statusfile`;
1747         die "$main::progname: cannot create named pipe $conf::statusfile: $errs"
1748                 if $?;
1749         chmod( 0644, $conf::statusfile )
1750                 or die "Cannot set modes of $conf::statusfile: $!\n";
1751
1752         # close log file, so that log rotating works
1753         close( LOG );
1754         close( STDOUT );
1755         close( STDERR );
1756
1757         while( 1 ) {
1758                 my( $status, $mup, $incw, $ds, $next_run, $last_ping, $currch, $l );
1759
1760                 # open the FIFO for writing; this blocks until someone (probably ftpd)
1761                 # opens it for reading
1762                 open( STATFIFO, ">$conf::statusfile" )
1763                         or die "Cannot open $conf::statusfile\n";
1764                 select( STATFIFO );
1765                 # tell main daemon to send us status infos
1766                 kill( $main::signo{"USR1"}, $main_pid );
1767
1768                 # get the infos from stdin; must loop until enough bytes received!
1769                 my $expect_len = 3 + 2*STATNUM_LEN + STATSTR_LEN;
1770                 for( $status = ""; ($l = length($status)) < $expect_len; ) {
1771                         sysread( STDIN, $status, $expect_len-$l, $l );
1772                 }
1773
1774                 # disassemble the status byte stream
1775                 my $pos = 0;
1776                 foreach ( [ mup => 1 ], [ incw => 1 ], [ ds => 1 ],
1777                                   [ next_run => STATNUM_LEN ], [ last_ping => STATNUM_LEN ],
1778                                   [ currch => STATSTR_LEN ] ) {
1779                         eval "\$$_->[0] = substr( \$status, $pos, $_->[1] );";
1780                         $pos += $_->[1];
1781                 }
1782                 $currch =~ s/\n+//g;
1783
1784                 print_status( $mup, $incw, $ds, $next_run, $last_ping, $currch );
1785                 close( STATFIFO );
1786
1787                 # This sleep is necessary so that we can't reopen the FIFO
1788                 # immediately, in case the reader hasn't closed it yet if we get to
1789                 # the open again. Is there a better solution for this??
1790                 sleep 1;
1791         }
1792 }
1793
1794 #
1795 # update the status file, in case we use a plain file and not a FIFO
1796 #
1797 sub write_status_file() {
1798
1799         return if !$conf::statusfile;
1800
1801         open( STATFILE, ">$conf::statusfile" ) or
1802                 (msg( "log", "Could not open $conf::statusfile: $!\n" ), return);
1803         my $oldsel = select( STATFILE );
1804
1805         print_status( $main::target_up, $main::incoming_writable, $main::dstat,
1806                                   $main::next_run, $main::last_ping_time,
1807                                   $main::current_changes );
1808
1809         select( $oldsel );
1810         close( STATFILE );
1811 }
1812
1813 sub print_status($$$$$$) {
1814         my $mup = shift;
1815         my $incw = shift;
1816         my $ds = shift;
1817         my $next_run = shift;
1818         my $last_ping = shift;
1819         my $currch = shift;
1820         my $approx;
1821         my $version;
1822
1823         ($version = 'Release: 0.9 $Revision: 1.51 $') =~ s/\$ ?//g;
1824         print "debianqueued $version\n";
1825
1826         $approx = $conf::statusdelay ? "approx. " : "";
1827
1828         if ($mup eq "0") {
1829                 print "$conf::target is down, queue pausing\n";
1830                 return;
1831         }
1832         elsif ($conf::upload_method ne "copy") {
1833                 print "$conf::target seems to be up, last ping $approx",
1834                           print_time(time-$last_ping), " ago\n";
1835         }
1836
1837         if ($incw eq "0") {
1838                 print "The incoming directory is not writable, queue pausing\n";
1839                 return;
1840         }
1841
1842         if ($ds eq "i") {
1843                 print "Next queue check in $approx",print_time($next_run-time),"\n";
1844                 return;
1845         }
1846         elsif ($ds eq "c") {
1847                 print "Checking queue directory\n";
1848         }
1849         elsif ($ds eq "u") {
1850                 print "Uploading to $conf::target\n";
1851         }
1852         else {
1853                 print "Bad status data from daemon: \"$mup$incw$ds\"\n";
1854                 return;
1855         }
1856
1857         print "Current job is $currch\n" if $currch;
1858 }
1859
1860 #
1861 # format a number for sending to statusd (fixed length STATNUM_LEN)
1862 #
1863 sub format_status_num(\$$) {
1864         my $varref = shift;
1865         my $num = shift;
1866
1867         $$varref = sprintf "%".STATNUM_LEN."d", $num;
1868 }
1869
1870 #
1871 # format a string for sending to statusd (fixed length STATSTR_LEN)
1872 #
1873 sub format_status_str(\$$) {
1874         my $varref = shift;
1875         my $str = shift;
1876
1877         $$varref = substr( $str, 0, STATSTR_LEN );
1878         $$varref .= "\n" x (STATSTR_LEN - length($$varref));
1879 }
1880
1881 #
1882 # send a status string to the status daemon
1883 #
1884 # Avoid all operations that could call malloc() here! Most libc
1885 # implementations aren't reentrant, so we may not call it from a
1886 # signal handler. So use only already-defined variables.
1887 #
1888 sub send_status() {
1889     local $! = 0; # preserve errno
1890
1891         # re-setup handler, in case we have broken SysV signals
1892         $SIG{"USR1"} = \&send_status;
1893
1894         syswrite( STATUSD, $main::target_up, 1 );
1895         syswrite( STATUSD, $main::incoming_writable, 1 );
1896         syswrite( STATUSD, $main::dstat, 1 );
1897         syswrite( STATUSD, $main::next_run, STATNUM_LEN );
1898         syswrite( STATUSD, $main::last_ping_time, STATNUM_LEN );
1899         syswrite( STATUSD, $main::current_changes, STATSTR_LEN );
1900 }
1901
1902
1903 # ---------------------------------------------------------------------------
1904 #                                                           FTP functions
1905 # ---------------------------------------------------------------------------
1906
1907 #
1908 # open FTP connection to target host if not already open
1909 #
1910 sub ftp_open() {
1911
1912         if ($main::FTP_chan) {
1913                 # is already open, but might have timed out; test with a cwd
1914                 return $main::FTP_chan if $main::FTP_chan->cwd( $main::current_targetdir );
1915                 # cwd didn't work, channel is closed, try to reopen it
1916                 $main::FTP_chan = undef;
1917         }
1918
1919         if (!($main::FTP_chan = Net::FTP->new( $conf::target,
1920                                                                                    Debug => $conf::ftpdebug,
1921                                                                                    Timeout => $conf::ftptimeout ))) {
1922                 msg( "log,mail", "Cannot open FTP server $conf::target\n" );
1923                 goto err;
1924         }
1925         if (!$main::FTP_chan->login()) {
1926                 msg( "log,mail", "Anonymous login on FTP server $conf::target failed\n" );
1927                 goto err;
1928         }
1929         if (!$main::FTP_chan->binary()) {
1930                 msg( "log,mail", "Can't set binary FTP mode on $conf::target\n" );
1931                 goto err;
1932         }
1933         if (!$main::FTP_chan->cwd( $main::current_targetdir )) {
1934                 msg( "log,mail", "Can't cd to $main::current_targetdir on $conf::target\n" );
1935                 goto err;
1936         }
1937         debug( "opened FTP channel to $conf::target" );
1938         return 1;
1939
1940   err:
1941         $main::FTP_chan = undef;
1942         return 0;
1943 }
1944
1945 sub ftp_cmd($@) {
1946         my $cmd = shift;
1947         my ($rv, $err);
1948         my $direct_resp_cmd = ($cmd eq "quot");
1949
1950         debug( "executing FTP::$cmd(".join(", ",@_).")" );
1951         $SIG{"ALRM"} = sub { die "timeout in FTP::$cmd\n" } ;
1952         alarm( $conf::remote_timeout );
1953         eval { $rv = $main::FTP_chan->$cmd( @_ ); };
1954         alarm( 0 );
1955         $err = "";
1956         $rv = (ftp_code() =~ /^2/) ? 1 : 0 if $direct_resp_cmd;
1957         if ($@) {
1958                 $err = $@;
1959                 undef $rv;
1960         }
1961         elsif (!$rv) {
1962                 $err = ftp_response();
1963         }
1964         return ($rv, $err);
1965 }
1966
1967 sub ftp_close() {
1968         if ($main::FTP_chan) {
1969                 $main::FTP_chan->quit();
1970                 $main::FTP_chan = undef;
1971         }
1972         return 1;
1973 }
1974
1975 sub ftp_response() {
1976         return join( '', @{${*$main::FTP_chan}{'net_cmd_resp'}} );
1977 }
1978
1979 sub ftp_code() {
1980         return ${*$main::FTP_chan}{'net_cmd_code'};
1981 }
1982
1983 sub ftp_error() {
1984         my $code = ftp_code();
1985         return ($code =~ /^[45]/) ? 1 : 0;
1986 }
1987
1988 # ---------------------------------------------------------------------------
1989 #                                                         utility functions
1990 # ---------------------------------------------------------------------------
1991
1992 sub ssh_cmd($) {
1993         my $cmd = shift;
1994         my ($msg, $stat);
1995
1996         my $ecmd = "$conf::ssh $conf::ssh_options $conf::target ".
1997                            "-l $conf::targetlogin \'cd $main::current_targetdir; $cmd\'";
1998         debug( "executing $ecmd" );
1999         $SIG{"ALRM"} = sub { die "timeout in ssh command\n" } ;
2000         alarm( $conf::remote_timeout );
2001         eval { $msg = `$ecmd 2>&1`; };
2002         alarm( 0 );
2003         if ($@) {
2004                 $msg = $@;
2005                 $stat = 1;
2006         }
2007         else {
2008                 $stat = $?;
2009         }
2010         return ($msg, $stat);
2011 }
2012
2013 sub scp_cmd(@) {
2014         my ($msg, $stat);
2015
2016         my $ecmd = "$conf::scp $conf::ssh_options @_ ".
2017                            "$conf::targetlogin\@$conf::target:$main::current_targetdir";
2018         debug( "executing $ecmd" );
2019         $SIG{"ALRM"} = sub { die "timeout in scp\n" } ;
2020         alarm( $conf::remote_timeout );
2021         eval { $msg = `$ecmd 2>&1`; };
2022         alarm( 0 );
2023         if ($@) {
2024                 $msg = $@;
2025                 $stat = 1;
2026         }
2027         else {
2028                 $stat = $?;
2029         }
2030         return ($msg, $stat);
2031 }
2032
2033 sub local_cmd($;$) {
2034         my $cmd = shift;
2035         my $nocd = shift;
2036         my ($msg, $stat);
2037
2038         my $ecmd = ($nocd ? "" : "cd $main::current_targetdir; ") . $cmd;
2039         debug( "executing $ecmd" );
2040         $msg = `($ecmd) 2>&1`;
2041         $stat = $?;
2042         return ($msg, $stat);
2043
2044 }
2045
2046 #
2047 # check if target is alive (code stolen from Net::Ping.pm)
2048 #
2049 sub check_alive(;$) {
2050     my $timeout = shift;
2051     my( $saddr, $ret, $target_ip );
2052     local( *PINGSOCK );
2053
2054         if ($conf::upload_method eq "copy") {
2055                 format_status_num( $main::last_ping_time, time );
2056                 $main::target_up = 1;
2057                 return;
2058         }
2059
2060     $timeout ||= 30;
2061
2062         if (!($target_ip = (gethostbyname($conf::target))[4])) {
2063                 msg( "log", "Cannot get IP address of $conf::target\n" );
2064                 $ret = 0;
2065                 goto out;
2066         }
2067     $saddr = pack( 'S n a4 x8', AF_INET, $main::echo_port, $target_ip );
2068     $SIG{'ALRM'} = sub { die } ;
2069     alarm( $timeout );
2070
2071         $ret = $main::tcp_proto; # avoid warnings about unused variable
2072     $ret = 0;
2073     eval <<'EOM' ;
2074     return unless socket( PINGSOCK, PF_INET, SOCK_STREAM, $main::tcp_proto );
2075     return unless connect( PINGSOCK, $saddr );
2076     $ret = 1;
2077 EOM
2078     alarm( 0 );
2079     close( PINGSOCK );
2080         msg( "log", "pinging $conf::target: " . ($ret ? "ok" : "down") . "\n" );
2081   out:
2082         $main::target_up = $ret ? "1" : "0";
2083         format_status_num( $main::last_ping_time, time );
2084         write_status_file() if $conf::statusdelay;
2085 }
2086
2087 #
2088 # check if incoming dir on target is writable
2089 #
2090 sub check_incoming_writable() {
2091         my $testfile = ".debianqueued-testfile";
2092         my ($msg, $stat);
2093
2094         if ($conf::upload_method eq "ssh") {
2095                 ($msg, $stat) = ssh_cmd( "rm -f $testfile; touch $testfile; ".
2096                                                                  "rm -f $testfile" );
2097         }
2098         elsif ($conf::upload_method eq "ftp") {
2099                 my $file = "junk-for-writable-test-".format_time();
2100                 $file =~ s/[ :.]/-/g;
2101                 local( *F );
2102                 open( F, ">$file" ); close( F );
2103                 my $rv;
2104                 ($rv, $msg) = ftp_cmd( "put", $file );
2105                 $stat = 0;
2106                 $msg = "" if !defined $msg;
2107                 unlink $file;
2108                 ftp_cmd( "delete", $file );
2109         }
2110         elsif ($conf::upload_method eq "copy") {
2111                 ($msg, $stat) = local_cmd( "rm -f $testfile; touch $testfile; ".
2112                                                                    "rm -f $testfile" );
2113         }
2114         chomp( $msg );
2115         debug( "exit status: $stat, output was: $msg" );
2116
2117         if (!$stat) {
2118                 # change incoming_writable only if ssh didn't return an error
2119                 $main::incoming_writable =
2120                         ($msg =~ /(permission denied|read-?only file|cannot create)/i) ? "0":"1";
2121         }
2122         else {
2123                 debug( "local error, keeping old status" );
2124         }
2125         debug( "incoming_writable = $main::incoming_writable" );
2126         write_status_file() if $conf::statusdelay;
2127         return $main::incoming_writable;
2128 }
2129
2130 #
2131 # remove a list of files, log failing ones
2132 #
2133 sub rm(@) {
2134         my $done = 0;
2135
2136         foreach ( @_ ) {
2137                 (unlink $_ and ++$done)
2138                         or $! == ENOENT or msg( "log", "Could not delete $_: $!\n" );
2139         }
2140         return $done;
2141 }
2142
2143 #
2144 # get md5 checksum of a file
2145 #
2146 sub md5sum($) {
2147         my $file = shift;
2148         my $line;
2149
2150         chomp( $line = `$conf::md5sum $file` );
2151         debug( "md5sum($file): ", $? ? "exit status $?" :
2152                                       $line =~ /^(\S+)/ ? $1 : "match failed" );
2153         return $? ? "" : $line =~ /^(\S+)/ ? $1 : "";
2154 }
2155
2156 #
2157 # check if a file probably belongs to a Debian upload
2158 #
2159 sub is_debian_file($) {
2160         my $file = shift;
2161         return $file =~ /\.(deb|dsc|(diff|tar)\.gz)$/ &&
2162                    $file !~ /\.orig\.tar\.gz/;
2163 }
2164
2165 #
2166 # try to extract maintainer email address from some a non-.changes file
2167 # return "" if not possible
2168 #
2169 sub get_maintainer($) {
2170         my $file = shift;
2171         my $maintainer = "";
2172         local( *F );
2173
2174         if ($file =~ /\.diff\.gz$/) {
2175                 # parse a diff
2176                 open( F, "$conf::gzip -dc '$file' 2>/dev/null |" ) or return "";
2177                 while( <F> ) {
2178                         # look for header line of a file */debian/control
2179                         last if m,^\+\+\+\s+[^/]+/debian/control(\s+|$),;
2180                 }
2181                 while( <F> ) {
2182                         last if /^---/; # end of control file patch, no Maintainer: found
2183                         # inside control file patch look for Maintainer: field
2184                         $maintainer = $1, last if /^\+Maintainer:\s*(.*)$/i;
2185                 }
2186                 while( <F> ) { } # read to end of file to avoid broken pipe
2187                 close( F ) or return "";
2188         }
2189         elsif ($file =~ /\.(deb|dsc|tar\.gz)$/) {
2190                 if ($file =~ /\.deb$/ && $conf::ar) {
2191                         # extract control.tar.gz from .deb with ar, then let tar extract
2192                         # the control file itself
2193                         open( F, "($conf::ar p '$file' control.tar.gz | ".
2194                                      "$conf::tar -xOf - ".
2195                                      "--use-compress-program $conf::gzip ".
2196                                      "control) 2>/dev/null |" )
2197                                 or return "";
2198                 }
2199                 elsif ($file =~ /\.dsc$/) {
2200                         # just do a plain grep
2201                         debug( "get_maint: .dsc, no cmd" );
2202                         open( F, "<$file" ) or return "";
2203                 }
2204                 elsif ($file =~ /\.tar\.gz$/) {
2205                         # let tar extract a file */debian/control
2206                         open(F, "$conf::tar -xOf '$file' ".
2207                                     "--use-compress-program $conf::gzip ".
2208                                     "\\*/debian/control 2>&1 |")
2209                                 or return "";
2210                 }
2211                 else {
2212                         return "";
2213                 }
2214                 while( <F> ) {
2215                         $maintainer = $1, last if /^Maintainer:\s*(.*)$/i;
2216                 }
2217                 close( F ) or return "";
2218         }
2219
2220         return $maintainer;
2221 }
2222
2223 #
2224 # return a pattern that matches all files that probably belong to one job
2225 #
2226 sub debian_file_stem($) {
2227         my $file = shift;
2228         my( $pkg, $version );
2229
2230         # strip file suffix
2231         $file =~ s,\.(deb|dsc|changes|(orig\.)?tar\.gz|diff\.gz)$,,;
2232         # if not is *_* (name_version), can't derive a stem and return just
2233         # the file's name
2234         return $file if !($file =~ /^([^_]+)_([^_]+)/);
2235         ($pkg, $version) = ($1, $2);
2236         # strip Debian revision from version
2237         $version =~ s/^(.*)-[\d.+-]+$/$1/;
2238
2239         return "${pkg}_${version}*";
2240 }
2241
2242 #
2243 # output a messages to several destinations
2244 #
2245 # first arg is a comma-separated list of destinations; valid are "log"
2246 # and "mail"; rest is stuff to be printed, just as with print
2247 #
2248 sub msg($@) {
2249         my @dest = split( ',', shift );
2250
2251         if (grep /log/, @dest ) {
2252                 my $now = format_time();
2253                 print LOG "$now ", @_;
2254         }
2255
2256         if (grep /mail/, @dest ) {
2257                 $main::mail_text .= join( '', @_ );
2258         }
2259 }
2260
2261 #
2262 # print a debug messages, if $debug is true
2263 #
2264 sub debug(@) {
2265         return if !$conf::debug;
2266         my $now = format_time();
2267         print LOG "$now DEBUG ", @_, "\n";
2268 }
2269
2270 #
2271 # intialize the "mail" destination of msg() (this clears text,
2272 # address, subject, ...)
2273 #
2274 sub init_mail(;$) {
2275         my $file = shift;
2276
2277         $main::mail_addr = "";
2278         $main::mail_text = "";
2279         %main::packages  = ();
2280         $main::mail_subject = $file ? "Processing of $file" : "";
2281 }
2282
2283 #
2284 # finalize mail to be sent from msg(): check if something present, and
2285 # then send out
2286 #
2287 sub finish_mail() {
2288
2289         debug( "No mail for $main::mail_addr" )
2290                 if $main::mail_addr && !$main::mail_text;
2291         return unless $main::mail_addr && $main::mail_text;
2292
2293         if (!send_mail($main::mail_addr, $main::mail_subject, $main::mail_text)) {
2294                 # store this mail in memory so it isn't lost if executing sendmail
2295                 # failed.
2296                 push( @main::stored_mails, { addr    => $main::mail_addr,
2297                                                                          subject => $main::mail_subject,
2298                                                                          text    => $main::mail_text } );
2299         }
2300         init_mail();
2301
2302         # try to send out stored mails
2303         my $mailref;
2304         while( $mailref = shift(@main::stored_mails) ) {
2305                 if (!send_mail( $mailref->{'addr'}, $mailref->{'subject'},
2306                                             $mailref->{'text'} )) {
2307                         unshift( @main::stored_mails, $mailref );
2308                         last;
2309                 }
2310         }
2311 }
2312
2313 #
2314 # send one mail
2315 #
2316 sub send_mail($$$) {
2317         my $addr = shift;
2318         my $subject = shift;
2319         my $text = shift;
2320
2321         my $package = keys %main::packages ? join(' ', keys %main::packages) : "";
2322
2323         use Email::Send;
2324
2325         unless (defined($Email::Send::Sendmail::SENDMAIL)) {
2326                 $Email::Send::Sendmail::SENDMAIL = $conf::mail;
2327         }
2328
2329         my $date = sprintf "%s", strftime("%a, %d %b %Y %T %z", (localtime(time)));
2330         my $message = <<__MESSAGE__;
2331 To: $addr
2332 From: Archive Administrator <dak\@ftp-master.debian.org>
2333 Subject: $subject
2334 Date: $date
2335 X-Debian: DAK
2336 __MESSAGE__
2337
2338         if (length $package) {
2339                 $message .= "X-Debian-Package: $package\n";
2340         }
2341
2342         $message .= "\n$text";
2343         $message .= "\nGreetings,\n\n\tYour Debian queue daemon\n";
2344
2345         my $mail = Email::Send->new;
2346         for ( qw[Sendmail SMTP] ) {
2347                 $mail->mailer($_) and last if $mail->mailer_available($_);
2348         }
2349
2350         my $ret = $mail->send($message);
2351         if ($ret && $ret !~ /Message sent|success/) {
2352                 return 0;
2353         }
2354
2355         return 1;
2356 }
2357
2358 #
2359 # try to find a mail address for a name in the keyrings
2360 #
2361 sub try_to_get_mail_addr($$) {
2362         my $name = shift;
2363         my $listref = shift;
2364
2365         @$listref = ();
2366         open( F, "$conf::gpg --no-options --batch --no-default-keyring ".
2367                 "--always-trust --keyring ".
2368                 join (" --keyring ",@conf::keyrings).
2369                 " --list-keys |" )
2370                 or return "";
2371         while( <F> ) {
2372                 if (/^pub / && / $name /) {
2373                         /<([^>]*)>/;
2374                         push( @$listref, $1 );
2375                 }
2376         }
2377         close( F );
2378
2379         return (@$listref >= 1) ? $listref->[0] : "";
2380 }
2381
2382 #
2383 # return current time as string
2384 #
2385 sub format_time() {
2386         my $t;
2387
2388         # omit weekday and year for brevity
2389         ($t = localtime) =~ /^\w+\s(.*)\s\d+$/;
2390         return $1;
2391 }
2392
2393 sub print_time($) {
2394         my $secs = shift;
2395         my $hours = int($secs/(60*60));
2396
2397         $secs -= $hours*60*60;
2398         return sprintf "%d:%02d:%02d", $hours, int($secs/60), $secs % 60;
2399 }
2400
2401 #
2402 # block some signals during queue processing
2403 #
2404 # This is just to avoid data inconsistency or uploads being aborted in the
2405 # middle. Only "soft" signals are blocked, i.e. SIGINT and SIGTERM, try harder
2406 # ones if you really want to kill the daemon at once.
2407 #
2408 sub block_signals() {
2409         POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset );
2410 }
2411
2412 sub unblock_signals() {
2413         POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset );
2414 }
2415
2416 #
2417 # process SIGHUP: close log file and reopen it (for logfile cycling)
2418 #
2419 sub close_log($) {
2420         close( LOG );
2421         close( STDOUT );
2422         close( STDERR );
2423
2424         open( LOG, ">>$conf::logfile" )
2425                 or die "Cannot open my logfile $conf::logfile: $!\n";
2426         chmod( 0644, $conf::logfile )
2427                 or msg( "log", "Cannot set modes of $conf::logfile: $!\n" );
2428         select( (select(LOG), $| = 1)[0] );
2429
2430         open( STDOUT, ">&LOG" )
2431                 or msg( "log", "$main::progname: Can't redirect stdout to ".
2432                             "$conf::logfile: $!\n" );
2433         open( STDERR, ">&LOG" )
2434                 or msg( "log", "$main::progname: Can't redirect stderr to ".
2435                             "$conf::logfile: $!\n" );
2436         msg( "log", "Restart after SIGHUP\n" );
2437 }
2438
2439 #
2440 # process SIGCHLD: check if it was our statusd process
2441 #
2442 sub kid_died($) {
2443         my $pid;
2444
2445         # reap statusd, so that it's no zombie when we try to kill(0) it
2446         waitpid( $main::statusd_pid, WNOHANG );
2447
2448 # Uncomment the following line if your Perl uses unreliable System V signal
2449 # (i.e. if handlers reset to default if the signal is delivered).
2450 # (Unfortunately, the re-setup can't be done in any case, since on some
2451 # systems this will cause the SIGCHLD to be delivered again if there are
2452 # still unreaped children :-(( )
2453
2454 #        $SIG{"CHLD"} = \&kid_died; # resetup handler for SysV
2455 }
2456
2457 sub restart_statusd() {
2458         # restart statusd if it died
2459         if (!kill( 0, $main::statusd_pid)) {
2460                 close( STATUSD ); # close out pipe end
2461                 $main::statusd_pid = fork_statusd();
2462         }
2463 }
2464
2465 #
2466 # process a fatal signal: cleanup and exit
2467 #
2468 sub fatal_signal($) {
2469         my $signame = shift;
2470         my $sig;
2471
2472         # avoid recursions of fatal_signal in case of BSD signals
2473         foreach $sig ( qw( ILL ABRT BUS FPE SEGV PIPE ) ) {
2474                 $SIG{$sig} = "DEFAULT";
2475         }
2476
2477         if ($$ == $main::maind_pid) {
2478                 # only the main daemon should do this
2479                 kill( $main::signo{"TERM"}, $main::statusd_pid )
2480                         if defined $main::statusd_pid;
2481                 unlink( $conf::statusfile, $conf::pidfile );
2482         }
2483         msg( "log", "Caught SIG$signame -- exiting (pid $$)\n" );
2484         exit 1;
2485 }
2486
2487
2488 # Local Variables:
2489 #  tab-width: 4
2490 #  fill-column: 78
2491 # End: