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