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