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