tools/debianqueued-0.9/debianqueued

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