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