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