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