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