tools/debianqueued-0.9/debianqueued

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