3 # debianqueued -- daemon for managing Debian upload queues
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>
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!
19 use POSIX qw( strftime sys_stat_h sys_wait_h signal_h );
22 use Socket qw( PF_INET AF_INET SOCK_STREAM );
27 setlocale(&POSIX::LC_ALL, "C");
29 # ---------------------------------------------------------------------------
31 # ---------------------------------------------------------------------------
34 ( $conf::queued_dir = ( ( $0 !~ m,^/, ) ? POSIX::getcwd() . "/" : "" ) . $0 )
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;
50 $junk = $conf::check_md5sum;
54 $junk = $conf::ftpdebug;
55 $junk = $conf::ftptimeout;
56 $junk = $conf::no_changes_timeout;
57 $junk = @conf::nonus_packages;
58 $junk = @conf::test_binaries;
59 $junk = @conf::maintainer_mail;
60 $junk = @conf::targetdir_delayed;
61 $junk = $conf::mail ||= '/usr/sbin/sendmail';
62 $conf::target = "localhost" if $conf::upload_method eq "copy";
66 ( $main::progname = $0 ) =~ s,.*/,,;
68 ($main::hostname, undef, undef, undef, undef) = gethostbyname(hostname());
72 # extract -r and -k args
74 if ( @ARGV == 1 && $ARGV[0] =~ /^-[rk]$/ ) {
75 $main::arg = ( $ARGV[0] eq '-k' ) ? "kill" : "restart";
79 # test for another instance of the queued already running
80 my ( $pid, $delayed_dirs, $adelayedcore );
81 if ( open( PIDFILE, "<$conf::pidfile" ) ) {
82 chomp( $pid = <PIDFILE> );
86 # remove stale pid file
87 unlink($conf::pidfile);
88 } elsif ($main::arg) {
90 print "Killing running daemon (pid $pid) ...";
93 while ( kill( 0, $pid ) && $cnt-- > 0 ) {
97 if ( kill( 0, $pid ) ) {
98 print " failed!\nProcess $pid still running.\n";
102 if ( -e "$conf::incoming/core" ) {
103 unlink("$conf::incoming/core");
104 print "(Removed core file)\n";
106 for ( $delayed_dirs = 0 ;
107 $delayed_dirs <= $conf::max_delayed ;
111 sprintf( "$conf::incoming_delayed/core", $delayed_dirs );
112 if ( -e $adelayedcore ) {
113 unlink($adelayedcore);
114 print "(Removed core file)\n";
116 } ## end for ( $delayed_dirs = 0...
117 exit 0 if $main::arg eq "kill";
119 die "Another $main::progname is already running (pid $pid)\n"
120 if $pid && kill( 0, $pid );
122 } elsif ( $main::arg eq "kill" ) {
123 die "No daemon running\n";
124 } elsif ( $main::arg eq "restart" ) {
125 print "(No daemon running; starting anyway)\n";
128 # if started without arguments (initial invocation), then fork
131 # now go to background
132 die "$main::progname: fork failed: $!\n"
133 unless defined( $pid = fork );
136 # parent: wait for signal from child (SIGCHLD or SIGUSR1) and exit
137 my $sigset = POSIX::SigSet->new();
139 $SIG{"CHLD"} = sub { };
140 $SIG{"USR1"} = sub { };
141 POSIX::sigsuspend($sigset);
142 waitpid( $pid, WNOHANG );
143 if ( kill( 0, $pid ) ) {
144 print "Daemon (on $main::hostname) started in background (pid $pid)\n";
153 if ( $conf::upload_method eq "ssh" ) {
155 # exec an ssh-agent that starts us again
156 # force shell to be /bin/sh, ssh-agent may base its decision
157 # whether to use a fd or a Unix socket on the shell...
158 $ENV{"SHELL"} = "/bin/sh";
159 exec $conf::ssh_agent, $0, "startup", getppid();
160 die "$main::progname: Could not exec $conf::ssh_agent: $!\n";
163 # no need to exec, just set up @ARGV as expected below
164 @ARGV = ( "startup", getppid() );
166 } ## end else [ if ($pid)
167 } ## end if ( !@ARGV )
168 die "Please start without any arguments.\n"
169 if @ARGV != 2 || $ARGV[0] ne "startup";
170 my $parent_pid = $ARGV[1];
174 ( $version = 'Release: 0.95' ) =~ s/\$ ?//g;
175 print "debianqueued $version\n";
178 # check if all programs exist
180 foreach $prg ( $conf::gpg, $conf::ssh, $conf::scp, $conf::ssh_agent,
181 $conf::ssh_add, $conf::md5sum, $conf::mail, $conf::mkfifo )
183 die "Required program $prg doesn't exist or isn't executable\n"
186 # check for correct upload method
187 die "Bad upload method '$conf::upload_method'.\n"
188 if $conf::upload_method ne "ssh"
189 && $conf::upload_method ne "ftp"
190 && $conf::upload_method ne "copy";
191 die "No keyrings\n" if !@conf::keyrings;
193 } ## end foreach $prg ( $conf::gpg, ...
194 die "statusfile path must be absolute."
195 if $conf::statusfile !~ m,^/,;
196 die "upload and target queue paths must be absolute."
197 if $conf::incoming !~ m,^/,
198 || $conf::incoming_delayed !~ m,^/,
199 || $conf::targetdir !~ m,^/,
200 || $conf::targetdir_delayed !~ m,^/,;
202 # ---------------------------------------------------------------------------
204 # ---------------------------------------------------------------------------
209 sub get_filelist_from_known_good_changes($);
210 sub age_delayed_queues();
211 sub process_changes($\@);
212 sub process_commands($);
213 sub age_delayed_queues();
214 sub is_on_target($\@);
215 sub copy_to_target(@);
218 sub check_incoming_writable();
220 sub write_status_file();
221 sub print_status($$$$$$);
222 sub format_status_num(\$$);
223 sub format_status_str(\$$);
235 sub check_incoming_writable();
238 sub is_debian_file($);
239 sub get_maintainer($);
240 sub debian_file_stem($);
246 sub try_to_get_mail_addr($$);
250 sub unblock_signals();
253 sub restart_statusd();
256 $ENV{"PATH"} = "/bin:/usr/bin";
257 $ENV{"IFS"} = "" if defined( $ENV{"IFS"} && $ENV{"IFS"} ne "" );
270 sub ST_CTIME() { 10 }
272 # fixed lengths of data items passed over status pipe
273 sub STATNUM_LEN() { 30 }
274 sub STATSTR_LEN() { 128 }
276 # init list of signals
277 defined $Config{sig_name}
278 or die "$main::progname: No signal list defined!\n";
281 foreach $name ( split( ' ', $Config{sig_name} ) ) {
282 $main::signo{$name} = $i++;
285 @main::fatal_signals = qw( INT QUIT ILL TRAP ABRT BUS FPE USR2 SEGV PIPE
286 TERM XCPU XFSZ PWR );
288 $main::block_sigset = POSIX::SigSet->new;
289 $main::block_sigset->addset( $main::signo{"INT"} );
290 $main::block_sigset->addset( $main::signo{"TERM"} );
292 # some constant net stuff
293 $main::tcp_proto = ( getprotobyname('tcp') )[2]
294 or die "Cannot get protocol number for 'tcp'\n";
295 my $used_service = ( $conf::upload_method eq "ssh" ) ? "ssh" : "ftp";
296 $main::echo_port = ( getservbyname( $used_service, 'tcp' ) )[2]
297 or die "Cannot get port number for service '$used_service'\n";
299 # clear queue of stored mails
300 @main::stored_mails = ();
302 # run ssh-add to bring the key into the agent (will use stdin/stdout)
303 if ( $conf::upload_method eq "ssh" ) {
304 system "$conf::ssh_add $conf::ssh_key_file"
305 and die "$main::progname: Running $conf::ssh_add failed "
306 . "(exit status ", $? >> 8, ")\n";
309 # change to queue dir
310 chdir($conf::incoming)
311 or die "$main::progname: cannot cd to $conf::incoming: $!\n";
313 # needed before /dev/null redirects, some system send a SIGHUP when loosing
314 # the controlling tty
315 $SIG{"HUP"} = "IGNORE";
317 # open logfile, make it unbuffered
318 open( LOG, ">>$conf::logfile" )
319 or die "Cannot open my logfile $conf::logfile: $!\n";
320 chmod( 0644, $conf::logfile )
321 or die "Cannot set modes of $conf::logfile: $!\n";
322 select( ( select(LOG), $| = 1 )[0] );
325 $SIG{"HUP"} = \&close_log;
327 # redirect stdin, ... to /dev/null
328 open( STDIN, "</dev/null" )
329 or die "$main::progname: Can't redirect stdin to /dev/null: $!\n";
330 open( STDOUT, ">&LOG" )
331 or die "$main::progname: Can't redirect stdout to $conf::logfile: $!\n";
332 open( STDERR, ">&LOG" )
333 or die "$main::progname: Can't redirect stderr to $conf::logfile: $!\n";
335 # ok, from this point usually no "die" anymore, stderr is gone!
336 msg( "log", "daemon (pid $$) (on $main::hostname) started\n" );
338 # initialize variables used by send_status before launching the status daemon
340 format_status_num( $main::next_run, time + 10 );
341 format_status_str( $main::current_changes, "" );
343 $main::incoming_writable = 1; # assume this for now
345 # start the daemon watching the 'status' FIFO
346 if ( $conf::statusfile && $conf::statusdelay == 0 ) {
347 $main::statusd_pid = fork_statusd();
348 $SIG{"CHLD"} = \&kid_died; # watch out for dead status daemon
349 # SIGUSR1 triggers status info
350 $SIG{"USR1"} = \&send_status;
351 } ## end if ( $conf::statusfile...
352 $main::maind_pid = $$;
355 kill( $main::signo{"ABRT"}, $$ )
356 if defined $main::signo{"ABRT"};
360 open( PIDFILE, ">$conf::pidfile" )
361 or msg( "log", "Can't open $conf::pidfile: $!\n" );
362 printf PIDFILE "%5d\n", $$;
364 chmod( 0644, $conf::pidfile )
365 or die "Cannot set modes of $conf::pidfile: $!\n";
367 # other signals will just log an error and exit
368 foreach (@main::fatal_signals) {
369 $SIG{$_} = \&fatal_signal;
372 # send signal to user-started process that we're ready and it can exit
373 kill( $main::signo{"USR1"}, $parent_pid );
375 # ---------------------------------------------------------------------------
377 # ---------------------------------------------------------------------------
379 # default to classical incoming/target
380 $main::current_incoming = $conf::incoming;
381 $main::current_targetdir = $conf::targetdir;
384 write_status_file() if $conf::statusdelay;
387 # ping target only if there is the possibility that we'll contact it (but
388 # also don't wait too long).
389 my @have_changes = <*.changes *.commands>;
390 for ( my $delayed_dirs = 0 ;
391 $delayed_dirs <= $conf::max_delayed ;
394 my $adelayeddir = sprintf( "$conf::incoming_delayed", $delayed_dirs );
395 push( @have_changes, <$adelayeddir/*.changes> );
396 } ## end for ( my $delayed_dirs ...
398 if @have_changes || ( time - $main::last_ping_time ) > 8 * 60 * 60;
400 if ( @have_changes && $main::target_up ) {
401 check_incoming_writable if !$main::incoming_writable;
402 check_dir() if $main::incoming_writable;
405 write_status_file() if $conf::statusdelay;
407 if ( $conf::upload_method eq "copy" ) {
408 age_delayed_queues();
411 # sleep() returns if we received a signal (SIGUSR1 for status FIFO), so
412 # calculate the end time once and wait for it being reached.
413 format_status_num( $main::next_run, time + $conf::queue_delay );
415 while ( ( $delta = calc_delta() ) > 0 ) {
416 debug("mainloop sleeping $delta secs");
419 # check if statusd died, if using status FIFO, or update status file
420 if ($conf::statusdelay) {
425 } ## end while ( ( $delta = calc_delta...
431 $delta = $main::next_run - time;
432 $delta = $conf::statusdelay
433 if $conf::statusdelay && $conf::statusdelay < $delta;
435 } ## end sub calc_delta()
437 # ---------------------------------------------------------------------------
438 # main working functions
439 # ---------------------------------------------------------------------------
442 # main function for checking the incoming dir
445 my ( @files, @changes, @keep_files, @this_keep_files, @stats, $file,
448 debug("starting checkdir");
450 write_status_file() if $conf::statusdelay;
452 # test if needed binaries are available; this is if they're on maybe
453 # slow-mounted NFS filesystems
454 foreach (@conf::test_binaries) {
457 # maybe the mount succeeds now
460 msg( "log", "binary test failed for $_; delaying queue run\n" );
462 } ## end foreach (@conf::test_binaries)
464 for ( $adelay = -1 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
465 if ( $adelay == -1 ) {
466 $main::current_incoming = $conf::incoming;
467 $main::current_incoming_short = "";
468 $main::current_targetdir = $conf::targetdir;
470 $main::current_incoming = sprintf( $conf::incoming_delayed, $adelay );
471 $main::current_incoming_short = sprintf( "DELAYED/%d-day", $adelay );
472 $main::current_targetdir = sprintf( $conf::targetdir_delayed, $adelay );
475 # need to clear directory specific variables
477 undef(@this_keep_files);
479 chdir($main::current_incoming)
483 "Cannot change to dir "
484 . "${main::current_incoming_short}: $!\n"
489 # look for *.commands files but not in delayed queues
490 if ( $adelay == -1 ) {
491 foreach $file (<*.commands>) {
494 process_commands($file);
497 write_status_file() if $conf::statusdelay;
499 } ## end foreach $file (<*.commands>)
500 } ## end if ( $adelay == -1 )
504 "log", "Cannot open dir ${main::current_incoming_short}: $!\n"
508 @files = readdir(INC);
511 # process all .changes files found
512 @changes = grep /\.changes$/, @files;
513 push( @keep_files, @changes ); # .changes files aren't stray
514 foreach $file (@changes) {
517 # wrap in an eval to allow jumpbacks to here with die in case
520 eval { process_changes( $file, @this_keep_files ); };
522 msg( "log,mail", $@ ) if $@;
524 write_status_file() if $conf::statusdelay;
526 # files which are ok in conjunction with this .changes
527 debug("$file tells to keep @this_keep_files");
528 push( @keep_files, @this_keep_files );
531 # break out of this loop if the incoming dir has become unwritable
532 goto end_run if !$main::incoming_writable;
533 } ## end foreach $file (@changes)
534 ftp_close() if $conf::upload_method eq "ftp";
536 # find files which aren't related to any .changes
537 foreach $file (@files) {
539 # filter out files we never want to delete
540 next if !-f $file || # may have disappeared in the meantime
543 || ( grep { $_ eq $file } @keep_files )
544 || $file =~ /$conf::keep_files/;
546 # Delete such files if they're older than
547 # $stray_remove_timeout; they could be part of an
548 # yet-incomplete upload, with the .changes still missing.
549 # Cannot send any notification, since owner unknown.
550 next if !( @stats = stat($file) );
551 my $age = time - $stats[ST_MTIME];
552 my ( $maint, $pattern, @job_files );
553 if ( $file =~ /^junk-for-writable-test/
554 || $file !~ m,$conf::valid_files,
555 || $age >= $conf::stray_remove_timeout )
558 "Deleted stray file ${main::current_incoming_short}/$file\n" )
561 $age > $conf::no_changes_timeout
562 && is_debian_file($file)
565 # not already reported
566 !( $stats[ST_MODE] & S_ISGID )
567 && ( $pattern = debian_file_stem($file) )
568 && ( @job_files = glob($pattern) )
571 # If a .changes is in the list, it has the same stem as the
572 # found file (probably a .orig.tar.gz). Don't report in this
574 !( grep( /\.changes$/, @job_files ) )
577 $maint = get_maintainer($file);
579 # Don't send a mail if this looks like the recompilation of a
580 # package for a non-i386 arch. For those, the maintainer field is
582 if ( !grep( /(\.dsc|_(i386|all)\.deb)$/, @job_files ) ) {
583 msg( "log", "Found an upload without .changes and with no ",
586 "Not sending a report, because probably ",
587 "recompilation job\n" );
590 $main::mail_addr = $maint;
591 $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
592 $main::mail_subject =
593 "Incomplete upload found in " . "Debian upload queue";
596 "Probably you are the uploader of the following "
599 msg( "mail", "the Debian upload queue directory:\n " );
600 msg( "mail", join( "\n ", @job_files ), "\n" );
603 "This looks like an upload, but a .changes file "
604 . "is missing, so the job\n"
606 msg( "mail", "cannot be processed.\n\n" );
609 "If no .changes file arrives within ",
610 print_time( $conf::stray_remove_timeout - $age ),
611 ", the files will be deleted.\n\n"
615 "If you didn't upload those files, please just "
616 . "ignore this message.\n"
621 "Sending problem report for an upload without a "
624 msg( "log", "Maintainer: $maint\n" );
628 "Found an upload without .changes, but can't "
629 . "find a maintainer address\n"
631 } ## end else [ if ( !grep( /(\.dsc|_(i386|all)\.deb)$/...
632 msg( "log", "Files: @job_files\n" );
634 # remember we already have sent a mail regarding this file
635 foreach (@job_files) {
637 next if !@st; # file may have disappeared in the meantime
638 chmod +( $st[ST_MODE] |= S_ISGID ), $_;
642 "found stray file ${main::current_incoming_short}/$file, deleting in ",
643 print_time( $conf::stray_remove_timeout - $age )
645 } ## end else [ if ( $file =~ /^junk-for-writable-test/...
646 } ## end foreach $file (@files)
647 } ## end for ( $adelay = -1 ; $adelay...
648 chdir($conf::incoming);
652 write_status_file() if $conf::statusdelay;
653 } ## end sub check_dir()
655 sub get_filelist_from_known_good_changes($) {
661 # parse the .changes file
662 open( CHANGES, "<$changes" )
663 or die "$changes: $!\n";
664 outer_loop: while (<CHANGES>) {
667 redo outer_loop if !/^\s/;
668 my @field = split(/\s+/);
671 # forbid shell meta chars in the name, we pass it to a
672 # subshell several times...
673 $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/;
674 if ( $1 ne $field[5] ) {
675 msg( "log", "found suspicious filename $field[5]\n" );
678 push( @filenames, $field[5] );
679 } ## end while (<CHANGES>)
680 } ## end if (/^Files:/i)
681 } ## end while (<CHANGES>)
684 } ## end sub get_filelist_from_known_good_changes($)
687 # process one .changes file
689 sub process_changes($\@) {
691 my $keep_list = shift;
693 $pgplines, @files, @filenames, @changes_stats,
694 $failure_file, $retries, $last_retry, $upload_time,
695 $file, $do_report, $ls_l, $problems_reported,
696 $errs, $pkgname, $signator
701 format_status_str( $main::current_changes,
702 "$main::current_incoming_short/$changes" );
704 write_status_file() if $conf::statusdelay;
707 msg( "log", "processing ${main::current_incoming_short}/$changes\n" );
709 # parse the .changes file
710 open( CHANGES, "<$changes" )
711 or die "Cannot open ${main::current_incoming_short}/$changes: $!\n";
713 $main::mail_addr = "";
715 outer_loop: while (<CHANGES>) {
716 if (/^---+(BEGIN|END) PGP .*---+$/) {
718 } elsif (/^Maintainer:\s*/i) {
719 chomp( $main::mail_addr = $' );
720 $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
721 } elsif (/^Source:\s*/i) {
722 chomp( $pkgname = $' );
723 $pkgname =~ s/\s+$//;
724 $main::packages{$pkgname}++;
725 } elsif (/^Files:/i) {
727 redo outer_loop if !/^\s/;
728 my @field = split(/\s+/);
731 # forbid shell meta chars in the name, we pass it to a
732 # subshell several times...
733 $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/;
734 if ( $1 ne $field[5] ) {
735 msg( "log", "found suspicious filename $field[5]\n" );
738 "File '$field[5]' mentioned in $main::current_incoming_short/$changes\n",
739 "has bad characters in its name. Removed.\n"
743 } ## end if ( $1 ne $field[5] )
752 push( @filenames, $field[5] );
753 debug( "includes file $field[5], size $field[2], ", "md5 $field[1]" );
754 } ## end while (<CHANGES>)
755 } ## end elsif (/^Files:/i)
756 } ## end while (<CHANGES>)
759 # tell check_dir that the files mentioned in this .changes aren't stray,
760 # we know about them somehow
761 @$keep_list = @filenames;
763 # some consistency checks
764 if ( !$main::mail_addr ) {
766 "$main::current_incoming_short/$changes doesn't contain a Maintainer: field; "
767 . "cannot process\n" );
768 goto remove_only_changes;
769 } ## end if ( !$main::mail_addr)
770 if ( $main::mail_addr !~ /^(buildd_\S+-\S+|\S+\@\S+\.\S+)/ ) {
772 # doesn't look like a mail address, maybe only the name
773 my ( $new_addr, @addr_list );
774 if ( $new_addr = try_to_get_mail_addr( $main::mail_addr, \@addr_list ) ) {
776 # substitute (unique) found addr, but give a warning
779 "(The Maintainer: field didn't contain a proper "
784 "Looking for `$main::mail_addr' in the Debian "
785 . "keyring gave your address\n"
787 msg( "mail", "as unique result, so I used this.)\n" );
789 "Substituted $new_addr for malformed " . "$main::mail_addr\n" );
790 $main::mail_addr = $new_addr;
793 # not found or not unique: hold the job and inform queue maintainer
794 my $old_addr = $main::mail_addr;
795 $main::mail_addr = $conf::maintainer_mail;
798 "The job ${main::current_incoming_short}/$changes doesn't have a correct email\n"
800 msg( "mail", "address in the Maintainer: field:\n" );
801 msg( "mail", " $old_addr\n" );
802 msg( "mail", "A check for this in the Debian keyring gave:\n" );
805 ? " " . join( ", ", @addr_list ) . "\n"
807 msg( "mail", "Please fix this manually\n" );
810 "Bad Maintainer: field in ${main::current_incoming_short}/$changes: $old_addr\n"
812 goto remove_only_changes;
813 } ## end else [ if ( $new_addr = try_to_get_mail_addr...
814 } ## end if ( $main::mail_addr ...
815 if ( $pgplines < 3 ) {
818 "$main::current_incoming_short/$changes isn't signed with PGP/GnuPG\n"
820 msg( "log", "(uploader $main::mail_addr)\n" );
821 goto remove_only_changes;
822 } ## end if ( $pgplines < 3 )
825 "$main::current_incoming_short/$changes doesn't mention any files\n" );
826 msg( "log", "(uploader $main::mail_addr)\n" );
827 goto remove_only_changes;
828 } ## end if ( !@files )
830 # check for packages that shouldn't be processed
831 if ( grep( $_ eq $pkgname, @conf::nonus_packages ) ) {
834 "$pkgname is a package that must be uploaded "
835 . "to nonus.debian.org\n"
837 msg( "log,mail", "instead of target.\n" );
839 "Job rejected and removed all files belonging " . "to it:\n" );
840 msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
841 rm( $changes, @filenames );
843 } ## end if ( grep( $_ eq $pkgname...
845 $failure_file = $changes . ".failures";
846 $retries = $last_retry = 0;
847 if ( -f $failure_file ) {
848 open( FAILS, "<$failure_file" )
849 or die "Cannot open $main::current_incoming_short/$failure_file: $!\n";
852 ( $retries, $last_retry ) = ( $1, $2 )
853 if $line =~ /^(\d+)\s+(\d+)$/;
854 push( @$keep_list, $failure_file );
855 } ## end if ( -f $failure_file )
857 # run PGP on the file to check the signature
858 if ( !( $signator = pgp_check($changes) ) ) {
861 "$main::current_incoming_short/$changes has bad PGP/GnuPG signature!\n"
863 msg( "log", "(uploader $main::mail_addr)\n" );
867 "Removing $main::current_incoming_short/$changes, but keeping its associated ",
872 # Set SGID bit on associated files, so that the test for Debian files
873 # without a .changes doesn't consider them.
874 foreach (@filenames) {
876 next if !@st; # file may have disappeared in the meantime
877 chmod +( $st[ST_MODE] |= S_ISGID ), $_;
880 } elsif ( $signator eq "LOCAL ERROR" ) {
882 # An error has appened when starting pgp... Don't process the file,
883 # but also don't delete it
885 "Can't PGP/GnuPG check $main::current_incoming_short/$changes -- don't process it for now"
888 } ## end elsif ( $signator eq "LOCAL ERROR")
890 die "Cannot stat ${main::current_incoming_short}/$changes (??): $!\n"
891 if !( @changes_stats = stat($changes) );
893 # Make $upload_time the maximum of all modification times of files
894 # related to this .changes (and the .changes it self). This is the
895 # last time something changes to these files.
896 $upload_time = $changes_stats[ST_MTIME];
899 next if !( @stats = stat( $file->{"name"} ) );
900 $file->{"stats"} = \@stats;
901 $upload_time = $stats[ST_MTIME] if $stats[ST_MTIME] > $upload_time;
902 } ## end for $file (@files)
904 $do_report = ( time - $upload_time ) > $conf::problem_report_timeout;
905 $problems_reported = $changes_stats[ST_MODE] & S_ISGID;
907 # if any of the files is newer than the .changes' ctime (the time
908 # we sent a report and set the sticky bit), send new problem reports
909 if ( $problems_reported && $changes_stats[ST_CTIME] < $upload_time ) {
910 $problems_reported = 0;
911 chmod +( $changes_stats[ST_MODE] &= ~S_ISGID ), $changes;
912 debug("upload_time>changes-ctime => resetting problems reported");
914 debug("do_report=$do_report problems_reported=$problems_reported");
916 # now check all files for correct size and md5 sum
918 my $filename = $file->{"name"};
919 if ( !defined( $file->{"stats"} ) ) {
921 # could be an upload that isn't complete yet, be quiet,
922 # but don't process the file;
923 msg( "log,mail", "$filename doesn't exist\n" )
924 if $do_report && !$problems_reported;
925 msg( "log", "$filename doesn't exist (ignored for now)\n" )
927 msg( "log", "$filename doesn't exist (already reported)\n" )
928 if $problems_reported;
930 } elsif ( $file->{"stats"}->[ST_SIZE] < $file->{"size"}
934 # could be an upload that isn't complete yet, be quiet,
935 # but don't process the file
936 msg( "log", "$filename is too small (ignored for now)\n" );
938 } elsif ( $file->{"stats"}->[ST_SIZE] != $file->{"size"} ) {
939 msg( "log,mail", "$filename has incorrect size; deleting it\n" );
942 } elsif ( md5sum($filename) ne $file->{"md5"} ) {
944 "$filename has incorrect md5 checksum; ",
948 } ## end elsif ( md5sum($filename)...
949 } ## end for $file (@files)
952 if ( ( time - $upload_time ) > $conf::bad_changes_timeout ) {
954 # if a .changes fails for a really long time (several days
955 # or so), remove it and all associated files
958 "$main::current_incoming_short/$changes couldn't be processed for ",
959 int( $conf::bad_changes_timeout / ( 60 * 60 ) ),
960 " hours and is now deleted\n"
962 msg( "log,mail", "All files it mentions are also removed:\n" );
963 msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
964 rm( $changes, @filenames, $failure_file );
965 } elsif ( $do_report && !$problems_reported ) {
967 # otherwise, send a problem report, if not done already
970 "Due to the errors above, the .changes file couldn't ",
972 "Please fix the problems for the upload to happen.\n"
975 # remember we already have sent a mail regarding this file
976 debug("Sending problem report mail and setting SGID bit");
977 my $mode = $changes_stats[ST_MODE] |= S_ISGID;
978 msg( "log", "chmod failed: $!" )
979 if ( chmod( $mode, $changes ) != 1 );
980 } ## end elsif ( $do_report && !$problems_reported)
987 # if this upload already failed earlier, wait until the delay requirement
990 && ( time - $last_retry ) <
991 ( $retries == 1 ? $conf::upload_delay_1 : $conf::upload_delay_2 ) )
993 msg( "log", "delaying retry of upload\n" );
995 } ## end if ( $retries > 0 && (...
997 if ( $conf::upload_method eq "ftp" ) {
998 return if !ftp_open();
1001 # check if the job is already present on target
1002 # (moved to here, to avoid bothering target as long as there are errors in
1004 if ( $ls_l = is_on_target( $changes, @filenames ) ) {
1007 "$main::current_incoming_short/$changes is already present on target host:\n"
1009 msg( "log,mail", "$ls_l\n" );
1011 "Either you already uploaded it, or someone else ",
1013 msg( "log,mail", "Job $changes removed.\n" );
1014 rm( $changes, @filenames, $failure_file );
1016 } ## end if ( $ls_l = is_on_target...
1018 # clear sgid bit before upload, scp would copy it to target. We don't need
1019 # it anymore, we know there are no problems if we come here. Also change
1020 # mode of files to 644 if this should be done locally.
1021 $changes_stats[ST_MODE] &= ~S_ISGID;
1022 if ( !$conf::chmod_on_target ) {
1023 $changes_stats[ST_MODE] &= ~0777;
1024 $changes_stats[ST_MODE] |= 0644;
1026 chmod +( $changes_stats[ST_MODE] ), $changes;
1028 # try uploading to target
1029 if ( !copy_to_target( $changes, @filenames ) ) {
1031 # if the upload failed, increment the retry counter and remember the
1032 # current time; both things are written to the .failures file. Don't
1033 # increment the fail counter if the error was due to incoming
1035 return if !$main::incoming_writable;
1036 if ( ++$retries >= $conf::max_upload_retries ) {
1038 "$changes couldn't be uploaded for $retries times now.\n" );
1040 "Giving up and removing it and its associated files:\n" );
1041 msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
1042 rm( $changes, @filenames, $failure_file );
1045 if ( open( FAILS, ">$failure_file" ) ) {
1046 print FAILS "$retries $last_retry\n";
1048 chmod( 0600, $failure_file )
1049 or die "Cannot set modes of $failure_file: $!\n";
1050 } ## end if ( open( FAILS, ">$failure_file"...
1051 push( @$keep_list, $failure_file );
1052 debug("now $retries failed uploads");
1055 "The upload will be retried in ",
1058 ? $conf::upload_delay_1
1059 : $conf::upload_delay_2
1063 } ## end else [ if ( ++$retries >= $conf::max_upload_retries)
1065 } ## end if ( !copy_to_target( ...
1067 # If the files were uploaded ok, remove them
1068 rm( $changes, @filenames, $failure_file );
1070 msg( "mail", "$changes uploaded successfully to $conf::target\n" );
1071 msg( "mail", "along with the files:\n ", join( "\n ", @filenames ),
1074 "$changes processed successfully (uploader $main::mail_addr)\n" );
1076 # Check for files that have the same stem as the .changes (and weren't
1077 # mentioned there) and delete them. It happens often enough that people
1078 # upload a .orig.tar.gz where it isn't needed and also not in the
1079 # .changes. Explicitly deleting it (and not waiting for the
1080 # $stray_remove_timeout) reduces clutter in the queue dir and maybe also
1081 # educates uploaders :-)
1083 # my $pattern = debian_file_stem( $changes );
1084 # my $spattern = substr( $pattern, 0, -1 ); # strip off '*' at end
1085 # my @other_files = glob($pattern);
1086 # filter out files that have a Debian revision at all and a different
1087 # revision. Those belong to a different upload.
1088 # if ($changes =~ /^\Q$spattern\E-([\d.+-]+)/) {
1089 # my $this_rev = $1;
1090 # @other_files = grep( !/^\Q$spattern\E-([\d.+-]+)/ || $1 eq $this_rev,
1093 # Also do not remove those files if a .changes is among them. Then there
1094 # is probably a second upload for another version or another architecture.
1095 # if (@other_files && !grep( /\.changes$/, @other_files )) {
1096 # rm( @other_files );
1097 # msg( "mail", "\nThe following file(s) seemed to belong to the same ".
1098 # "upload, but weren't listed\n" );
1099 # msg( "mail", "in the .changes file:\n " );
1100 # msg( "mail", join( "\n ", @other_files ), "\n" );
1101 # msg( "mail", "They have been deleted.\n" );
1102 # msg( "log", "Deleted files in upload not in $changes: @other_files\n" );
1104 } ## end sub process_changes($\@)
1107 # process one .commands file
1109 sub process_commands($) {
1110 my $commands = shift;
1111 my ( @cmds, $cmd, $pgplines, $signator );
1113 my ( @files, $file, @removed, $target_delay );
1115 format_status_str( $main::current_changes, $commands );
1117 write_status_file() if $conf::statusdelay;
1119 msg( "log", "processing $main::current_incoming_short/$commands\n" );
1121 # parse the .commands file
1122 if ( !open( COMMANDS, "<$commands" ) ) {
1123 msg( "log", "Cannot open $main::current_incoming_short/$commands: $!\n" );
1127 $main::mail_addr = "";
1129 outer_loop: while (<COMMANDS>) {
1130 if (/^---+(BEGIN|END) PGP .*---+$/) {
1132 } elsif (/^Uploader:\s*/i) {
1133 chomp( $main::mail_addr = $' );
1134 $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
1135 } elsif (/^Commands:/i) {
1138 s/^\s*(.*)\s*$/$1/; # delete whitespace at both ends
1141 debug("includes cmd $_");
1143 last outer_loop if !defined( $_ = scalar(<COMMANDS>) );
1145 redo outer_loop if !/^\s/ || /^$/;
1146 } ## end for ( ; ; )
1147 } ## end elsif (/^Commands:/i)
1148 } ## end while (<COMMANDS>)
1151 # some consistency checks
1152 if ( !$main::mail_addr || $main::mail_addr !~ /^\S+\@\S+\.\S+/ ) {
1154 "$main::current_incoming_short/$commands contains no or bad Uploader: field: "
1155 . "$main::mail_addr\n" );
1157 "cannot process $main::current_incoming_short/$commands\n" );
1158 $main::mail_addr = "";
1160 } ## end if ( !$main::mail_addr...
1161 msg( "log", "(command uploader $main::mail_addr)\n" );
1163 if ( $pgplines < 3 ) {
1166 "$main::current_incoming_short/$commands isn't signed with PGP/GnuPG\n"
1170 "or the uploaded file is broken. Make sure to transfer in binary mode\n"
1172 msg( "mail", "or better yet - use dcut for commands files\n" );
1174 } ## end if ( $pgplines < 3 )
1176 # run PGP on the file to check the signature
1177 if ( !( $signator = pgp_check($commands) ) ) {
1180 "$main::current_incoming_short/$commands has bad PGP/GnuPG signature!\n"
1183 msg( "log,mail", "Removing $main::current_incoming_short/$commands\n" );
1186 } elsif ( $signator eq "LOCAL ERROR" ) {
1188 # An error has appened when starting pgp... Don't process the file,
1189 # but also don't delete it
1191 "Can't PGP/GnuPG check $main::current_incoming_short/$commands -- don't process it for now"
1194 } ## end elsif ( $signator eq "LOCAL ERROR")
1195 msg( "log", "(PGP/GnuPG signature by $signator)\n" );
1197 # now process commands
1200 "Log of processing your commands file $main::current_incoming_short/$commands:\n\n"
1202 foreach $cmd (@cmds) {
1203 my @word = split( /\s+/, $cmd );
1204 msg( "mail,log", "> @word\n" );
1205 my $selecteddelayed = -1;
1208 if ( $word[0] eq "rm" ) {
1209 foreach ( @word[ 1 .. $#word ] ) {
1211 if (m,^DELAYED/([0-9]+)-day/,) {
1212 $selecteddelayed = $1;
1213 s,^DELAYED/[0-9]+-day/,,;
1216 msg("mail,log", "$_: filename component cannot start with a wildcard\n");
1217 } elsif ( $origword eq "--searchdirs" ) {
1218 $selecteddelayed = -2;
1222 "$_: filename may not contain slashes except for DELAYED/#-day/ prefixes\n"
1226 # process wildcards but also plain names
1228 my $pat = quotemeta($_);
1229 $pat =~ s/\\\*/.*/g;
1230 $pat =~ s/\\\?/.?/g;
1231 $pat =~ s/\\([][])/$1/g;
1233 if ( $selecteddelayed < 0 ) { # scanning or explicitly incoming
1234 opendir( DIR, "." );
1235 push( @thesefiles, grep /^$pat$/, readdir(DIR) );
1238 if ( $selecteddelayed >= 0 ) {
1239 my $dir = sprintf( $conf::incoming_delayed, $selecteddelayed );
1240 opendir( DIR, $dir );
1242 map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) );
1244 } elsif ( $selecteddelayed == -2 ) {
1245 for ( my ($adelay) = 0 ;
1246 ( !@thesefiles ) && $adelay <= $conf::max_delayed ;
1249 my $dir = sprintf( $conf::incoming_delayed, $adelay );
1250 opendir( DIR, $dir );
1252 map ( "$dir/$_", grep /^$pat$/, readdir(DIR) ) );
1254 } ## end for ( my ($adelay) = 0 ...
1255 } ## end elsif ( $selecteddelayed ...
1256 push( @files, @thesefiles );
1257 if ( !@thesefiles ) {
1258 msg( "mail,log", "$origword did not match anything\n" );
1260 } ## end else [ if ( $origword eq "--searchdirs")
1261 } ## end foreach ( @word[ 1 .. $#word...
1263 msg( "mail,log", "No files to delete\n" );
1266 foreach $file (@files) {
1268 msg( "mail,log", "$file: no such file\n" );
1269 } elsif ( $file =~ /$conf::keep_files/ ) {
1270 msg( "mail,log", "$file is protected, cannot " . "remove\n" );
1271 } elsif ( !unlink($file) ) {
1272 msg( "mail,log", "$file: rm: $!\n" );
1274 $file =~ s,$conf::incoming/?,,;
1275 push( @removed, $file );
1277 } ## end foreach $file (@files)
1278 msg( "mail,log", "Files removed: @removed\n" ) if @removed;
1279 } ## end else [ if ( !@files )
1280 } elsif ( $word[0] eq "reschedule" ) {
1282 msg( "mail,log", "Wrong number of arguments\n" );
1283 } elsif ( $conf::upload_method ne "copy" ) {
1284 msg( "mail,log", "reschedule not available\n" );
1285 } elsif ( $word[1] =~ m,/, || $word[1] !~ m/\.changes/ ) {
1288 "$word[1]: filename may not contain slashes and must be .changes\n"
1290 } elsif ( !( ($target_delay) = $word[2] =~ m,^([0-9]+)-day$, )
1291 || $target_delay > $conf::max_delayed )
1295 "$word[2]: rescheduling target must be #-day with # between 0 and $conf::max_delayed (in particular, no '/' allowed)\n"
1297 } elsif ( $word[1] =~ /$conf::keep_files/ ) {
1298 msg( "mail,log", "$word[1] is protected, cannot do stuff with it\n" );
1302 $adelay <= $conf::max_delayed
1304 sprintf( "$conf::targetdir_delayed", $adelay ) . "/$word[1]" ) ;
1307 } ## end for ( $adelay = 0 ; $adelay...
1308 if ( $adelay > $conf::max_delayed ) {
1309 msg( "mail,log", "$word[1] not found\n" );
1310 } elsif ( $adelay == $target_delay ) {
1311 msg( "mail,log", "$word[1] already is in $word[2]\n" );
1314 my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1316 sprintf( "$conf::targetdir_delayed", $target_delay );
1317 push( @thesefiles, $word[1] );
1319 get_filelist_from_known_good_changes("$dir/$word[1]") );
1320 for my $afile (@thesefiles) {
1321 if ( $afile =~ m/\.changes$/ ) {
1322 utime undef, undef, ("$dir/$afile");
1324 if ( !move("$dir/$afile", "$target_dir/$afile") ) {
1325 msg( "mail,log", "move: $!\n" );
1327 msg( "mail,log", "$afile moved to $target_delay-day\n" );
1329 } ## end for my $afile (@thesefiles)
1330 } ## end else [ if ( $adelay > $conf::max_delayed)
1331 } ## end else [ if ( @word != 3 )
1332 } elsif ( $word[0] eq "cancel" ) {
1334 msg( "mail,log", "Wrong number of arguments\n" );
1335 } elsif ( $conf::upload_method ne "copy" ) {
1336 msg( "mail,log", "cancel not available\n" );
1338 $word[1] !~ m,^[a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*\.changes$, )
1341 "argument to cancel must be one .changes filename without path\n" );
1342 } ## end elsif ( $word[1] !~ ...
1344 for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
1345 my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1346 if ( -f "$dir/$word[1]" ) {
1348 push( @files, "$word[1]" );
1350 get_filelist_from_known_good_changes("$dir/$word[1]") );
1351 foreach $file (@files) {
1352 if ( !-f "$dir/$file" ) {
1353 msg( "mail,log", "$dir/$file: no such file\n" );
1354 } elsif ( "$dir/$file" =~ /$conf::keep_files/ ) {
1356 "$dir/$file is protected, cannot " . "remove\n" );
1357 } elsif ( !unlink("$dir/$file") ) {
1358 msg( "mail,log", "$dir/$file: rm: $!\n" );
1360 push( @removed, $file );
1362 } ## end foreach $file (@files)
1363 msg( "mail,log", "Files removed from $adelay-day: @removed\n" )
1365 } ## end if ( -f "$dir/$word[1]")
1366 } ## end for ( my ($adelay) = 0 ...
1368 msg( "mail,log", "No upload found: $word[1]\n" );
1371 msg( "mail,log", "unknown command $word[0]\n" );
1373 } ## end foreach $cmd (@cmds)
1376 "-- End of $main::current_incoming_short/$commands processing\n" );
1377 } ## end sub process_commands($)
1379 sub age_delayed_queues() {
1380 for ( my ($adelay) = 0 ; $adelay <= $conf::max_delayed ; $adelay++ ) {
1381 my ($dir) = sprintf( "$conf::targetdir_delayed", $adelay );
1383 if ( $adelay == 0 ) {
1384 $target_dir = $conf::targetdir;
1386 $target_dir = sprintf( "$conf::targetdir_delayed", $adelay - 1 );
1388 for my $achanges (<$dir/*.changes>) {
1389 my $mtime = ( stat($achanges) )[9];
1390 if ( $mtime + 24 * 60 * 60 <= time || $adelay == 0 ) {
1391 utime undef, undef, ($achanges);
1392 my @thesefiles = ( $achanges =~ m,.*/([^/]*), );
1393 push( @thesefiles, get_filelist_from_known_good_changes($achanges) );
1394 for my $afile (@thesefiles) {
1395 if ( !move("$dir/$afile", "$target_dir/$afile") ) {
1396 msg( "log", "move: $!\n" );
1398 msg( "log", "$afile moved to $target_dir\n" );
1400 } ## end for my $afile (@thesefiles)
1401 } ## end if ( $mtime + 24 * 60 ...
1402 } ## end for my $achanges (<$dir/*.changes>)
1403 } ## end for ( my ($adelay) = 0 ...
1404 } ## end sub age_delayed_queues()
1407 # check if a file is already on target
1409 sub is_on_target($\@) {
1411 my $filelist = shift;
1415 if ( $conf::upload_method eq "ssh" ) {
1416 ( $msg, $stat ) = ssh_cmd("ls -l $file");
1417 } elsif ( $conf::upload_method eq "ftp" ) {
1419 ( $msg, $err ) = ftp_cmd( "dir", $file );
1425 $msg = "ls: no such file\n";
1428 $msg = join( "\n", @$msg );
1431 my @allfiles = ($file);
1432 push( @allfiles, @$filelist );
1434 $msg = "no such file";
1435 for my $afile (@allfiles) {
1436 if ( -f "$conf::targetdir/$afile" ) {
1440 } ## end for my $afile (@allfiles)
1441 for ( my ($adelay) = 0 ;
1442 $adelay <= $conf::max_delayed && $stat ;
1445 for my $afile (@allfiles) {
1447 -f ( sprintf( "$conf::targetdir_delayed", $adelay ) . "/$afile" ) )
1450 $msg = sprintf( "%d-day", $adelay ) . "/$afile";
1451 } ## end if ( -f ( sprintf( "$conf::targetdir_delayed"...
1452 } ## end for my $afile (@allfiles)
1453 } ## end for ( my ($adelay) = 0 ...
1454 } ## end else [ if ( $conf::upload_method...
1456 debug("exit status: $stat, output was: $msg");
1458 return "" if $stat && $msg =~ /no such file/i; # file not present
1459 msg( "log", "strange ls -l output on target:\n", $msg ), return ""
1460 if $stat || $@; # some other error, but still try to upload
1462 # ls -l returned 0 -> file already there
1463 $msg =~ s/\s\s+/ /g; # make multiple spaces into one, to save space
1465 } ## end sub is_on_target($\@)
1468 # copy a list of files to target
1470 sub copy_to_target(@) {
1472 my ( @md5sum, @expected_files, $sum, $name, $msgs, $stat );
1475 write_status_file() if $conf::statusdelay;
1478 if ( $conf::upload_method eq "ssh" ) {
1479 ( $msgs, $stat ) = scp_cmd(@files);
1481 } elsif ( $conf::upload_method eq "ftp" ) {
1483 if ( !$main::FTP_chan->cwd($main::current_targetdir) ) {
1485 "Can't cd to $main::current_targetdir on $conf::target\n" );
1488 foreach $file (@files) {
1489 ( $rv, $msgs ) = ftp_cmd( "put", $file );
1494 local_cmd( "$conf::cp @files $main::current_targetdir", 'NOCD' );
1498 # check md5sums or sizes on target against our own
1499 my $have_md5sums = 1;
1500 if ($conf::check_md5sum) {
1501 if ( $conf::upload_method eq "ssh" ) {
1502 ( $msgs, $stat ) = ssh_cmd("md5sum @files");
1504 @md5sum = split( "\n", $msgs );
1505 } elsif ( $conf::upload_method eq "ftp" ) {
1506 my ( $rv, $err, $file );
1507 foreach $file (@files) {
1508 ( $rv, $err ) = ftp_cmd( "quot", "site", "md5sum", $file );
1510 next if ftp_code() == 550; # file not found
1511 if ( ftp_code() == 500 ) { # unimplemented
1513 goto get_sizes_instead;
1518 chomp( my $t = ftp_response() );
1519 push( @md5sum, $t );
1520 } ## end foreach $file (@files)
1521 if ( !$have_md5sums ) {
1523 foreach $file (@files) {
1524 ( $rv, $err ) = ftp_cmd( "size", $file );
1526 next if ftp_code() == 550; # file not found
1530 push( @md5sum, "$rv $file" );
1531 } ## end foreach $file (@files)
1532 } ## end if ( !$have_md5sums )
1534 ( $msgs, $stat ) = local_cmd("$conf::md5sum @files");
1536 @md5sum = split( "\n", $msgs );
1539 @expected_files = @files;
1542 ( $sum, $name ) = split;
1543 next if !grep { $_ eq $name } @files; # a file we didn't upload??
1544 next if $sum eq "md5sum:"; # looks like an error message
1545 if ( ( $have_md5sums && $sum ne md5sum($name) )
1546 || ( !$have_md5sums && $sum != ( -s $name ) ) )
1550 "Upload of $name to $conf::target failed ",
1551 "(" . ( $have_md5sums ? "md5sum" : "size" ) . " mismatch)\n"
1554 } ## end if ( ( $have_md5sums &&...
1556 # seen that file, remove it from expect list
1557 @expected_files = map { $_ eq $name ? () : $_ } @expected_files;
1558 } ## end foreach (@md5sum)
1559 if (@expected_files) {
1560 msg( "log,mail", "Failed to upload the files\n" );
1561 msg( "log,mail", " ", join( ", ", @expected_files ), "\n" );
1562 msg( "log,mail", "(Not present on target after upload)\n" );
1564 } ## end if (@expected_files)
1565 } ## end if ($conf::check_md5sum)
1567 if ($conf::chmod_on_target) {
1569 # change file's mode explicitly to 644 on target
1570 if ( $conf::upload_method eq "ssh" ) {
1571 ( $msgs, $stat ) = ssh_cmd("chmod 644 @files");
1573 } elsif ( $conf::upload_method eq "ftp" ) {
1575 foreach $file (@files) {
1576 ( $rv, $msgs ) = ftp_cmd( "quot", "site", "chmod", "644", $file );
1577 msg( "log", "Can't chmod $file on target:\n$msgs" )
1580 } ## end foreach $file (@files)
1582 ( $msgs, $stat ) = local_cmd("$conf::chmod 644 @files");
1585 } ## end if ($conf::chmod_on_target)
1588 write_status_file() if $conf::statusdelay;
1593 "Upload to $conf::target failed",
1594 $? ? ", last exit status " . sprintf( "%s", $? >> 8 ) : "", "\n" );
1595 msg( "log,mail", "Error messages:\n", $msgs )
1598 # If "permission denied" was among the errors, test if the incoming is
1600 if ( $msgs =~ /(permission denied|read-?only file)/i ) {
1601 if ( !check_incoming_writable() ) {
1602 msg( "log,mail", "(The incoming directory seems to be ",
1605 } ## end if ( $msgs =~ /(permission denied|read-?only file)/i)
1607 # remove bad files or an incomplete upload on target
1608 if ( $conf::upload_method eq "ssh" ) {
1609 ssh_cmd("rm -f @files");
1610 } elsif ( $conf::upload_method eq "ftp" ) {
1612 foreach $file (@files) {
1614 ( $rv, $err ) = ftp_cmd( "delete", $file );
1615 msg( "log", "Can't delete $file on target:\n$err" )
1617 } ## end foreach $file (@files)
1619 my @tfiles = map { "$main::current_targetdir/$_" } @files;
1620 debug("executing unlink(@tfiles)");
1624 write_status_file() if $conf::statusdelay;
1626 } ## end sub copy_to_target(@)
1629 # check if a file is correctly signed with PGP
1640 if ( -x $conf::gpg ) {
1641 debug( "executing $conf::gpg --no-options --batch "
1642 . "--no-default-keyring --always-trust "
1644 . join( " --keyring ", @conf::keyrings )
1645 . " --verify '$file'" );
1648 "$conf::gpg --no-options --batch "
1649 . "--no-default-keyring --always-trust "
1651 . join( " --keyring ", @conf::keyrings )
1652 . " --verify '$file'"
1657 msg( "log", "Can't open pipe to $conf::gpg: $!\n" );
1658 return "LOCAL ERROR";
1659 } ## end if ( !open( PIPE, "$conf::gpg --no-options --batch "...
1660 $output .= $_ while (<PIPE>);
1663 } ## end if ( -x $conf::gpg )
1666 msg( "log,mail", "GnuPG signature check failed on $file\n" );
1667 msg( "mail", $output );
1668 msg( "log,mail", "(Exit status ", $stat >> 8, ")\n" );
1672 $output =~ /^(gpg: )?good signature from (user )?"(.*)"\.?$/im;
1673 ( $signator = $3 ) ||= "unknown signator";
1675 debug("GnuPG signature ok (by $signator)");
1678 } ## end sub pgp_check($)
1680 # ---------------------------------------------------------------------------
1682 # ---------------------------------------------------------------------------
1685 # fork a subprocess that watches the 'status' FIFO
1687 # that process blocks until someone opens the FIFO, then sends a
1688 # signal (SIGUSR1) to the main process, expects
1690 sub fork_statusd() {
1696 $statusd_pid = open( STATUSD, "|-" );
1697 die "cannot fork: $!\n" if !defined($statusd_pid);
1699 # parent just returns
1701 msg( "log", "forked status daemon (pid $statusd_pid)\n" );
1702 return $statusd_pid;
1705 # child: the status FIFO daemon
1707 # ignore SIGPIPE here, in case some closes the FIFO without completely
1709 $SIG{"PIPE"} = "IGNORE";
1711 # also ignore SIGCLD, we don't want to inherit the restart-statusd handler
1713 $SIG{"CHLD"} = "DEFAULT";
1715 rm($conf::statusfile);
1716 $errs = `$conf::mkfifo $conf::statusfile`;
1717 die "$main::progname: cannot create named pipe $conf::statusfile: $errs"
1719 chmod( 0644, $conf::statusfile )
1720 or die "Cannot set modes of $conf::statusfile: $!\n";
1722 # close log file, so that log rotating works
1728 my ( $status, $mup, $incw, $ds, $next_run, $last_ping, $currch, $l );
1730 # open the FIFO for writing; this blocks until someone (probably ftpd)
1731 # opens it for reading
1732 open( STATFIFO, ">$conf::statusfile" )
1733 or die "Cannot open $conf::statusfile\n";
1736 # tell main daemon to send us status infos
1737 kill( $main::signo{"USR1"}, $main_pid );
1739 # get the infos from stdin; must loop until enough bytes received!
1740 my $expect_len = 3 + 2 * STATNUM_LEN + STATSTR_LEN;
1741 for ( $status = "" ; ( $l = length($status) ) < $expect_len ; ) {
1742 sysread( STDIN, $status, $expect_len - $l, $l );
1745 # disassemble the status byte stream
1751 [ next_run => STATNUM_LEN ],
1752 [ last_ping => STATNUM_LEN ],
1753 [ currch => STATSTR_LEN ]
1756 eval "\$$_->[0] = substr( \$status, $pos, $_->[1] );";
1758 } ## end foreach ( [ mup => 1 ], [ incw...
1759 $currch =~ s/\n+//g;
1761 print_status( $mup, $incw, $ds, $next_run, $last_ping, $currch );
1764 # This sleep is necessary so that we can't reopen the FIFO
1765 # immediately, in case the reader hasn't closed it yet if we get to
1766 # the open again. Is there a better solution for this??
1769 } ## end sub fork_statusd()
1772 # update the status file, in case we use a plain file and not a FIFO
1774 sub write_status_file() {
1776 return if !$conf::statusfile;
1778 open( STATFILE, ">$conf::statusfile" )
1779 or ( msg( "log", "Could not open $conf::statusfile: $!\n" ), return );
1780 my $oldsel = select(STATFILE);
1783 $main::target_up, $main::incoming_writable,
1784 $main::dstat, $main::next_run,
1785 $main::last_ping_time, $main::current_changes
1790 } ## end sub write_status_file()
1792 sub print_status($$$$$$) {
1796 my $next_run = shift;
1797 my $last_ping = shift;
1802 ( $version = 'Release: 0.9 $Revision: 1.51 $' ) =~ s/\$ ?//g;
1803 print "debianqueued $version\n";
1805 $approx = $conf::statusdelay ? "approx. " : "";
1807 if ( $mup eq "0" ) {
1808 print "$conf::target is down, queue pausing\n";
1810 } elsif ( $conf::upload_method ne "copy" ) {
1811 print "$conf::target seems to be up, last ping $approx",
1812 print_time( time - $last_ping ), " ago\n";
1815 if ( $incw eq "0" ) {
1816 print "The incoming directory is not writable, queue pausing\n";
1821 print "Next queue check in $approx", print_time( $next_run - time ), "\n";
1823 } elsif ( $ds eq "c" ) {
1824 print "Checking queue directory\n";
1825 } elsif ( $ds eq "u" ) {
1826 print "Uploading to $conf::target\n";
1828 print "Bad status data from daemon: \"$mup$incw$ds\"\n";
1832 print "Current job is $currch\n" if $currch;
1833 } ## end sub print_status($$$$$$)
1836 # format a number for sending to statusd (fixed length STATNUM_LEN)
1838 sub format_status_num(\$$) {
1842 $$varref = sprintf "%" . STATNUM_LEN . "d", $num;
1843 } ## end sub format_status_num(\$$)
1846 # format a string for sending to statusd (fixed length STATSTR_LEN)
1848 sub format_status_str(\$$) {
1852 $$varref = substr( $str, 0, STATSTR_LEN );
1853 $$varref .= "\n" x ( STATSTR_LEN - length($$varref) );
1854 } ## end sub format_status_str(\$$)
1857 # send a status string to the status daemon
1859 # Avoid all operations that could call malloc() here! Most libc
1860 # implementations aren't reentrant, so we may not call it from a
1861 # signal handler. So use only already-defined variables.
1864 local $! = 0; # preserve errno
1866 # re-setup handler, in case we have broken SysV signals
1867 $SIG{"USR1"} = \&send_status;
1869 syswrite( STATUSD, $main::target_up, 1 );
1870 syswrite( STATUSD, $main::incoming_writable, 1 );
1871 syswrite( STATUSD, $main::dstat, 1 );
1872 syswrite( STATUSD, $main::next_run, STATNUM_LEN );
1873 syswrite( STATUSD, $main::last_ping_time, STATNUM_LEN );
1874 syswrite( STATUSD, $main::current_changes, STATSTR_LEN );
1875 } ## end sub send_status()
1877 # ---------------------------------------------------------------------------
1879 # ---------------------------------------------------------------------------
1882 # open FTP connection to target host if not already open
1886 if ($main::FTP_chan) {
1888 # is already open, but might have timed out; test with a cwd
1889 return $main::FTP_chan
1890 if $main::FTP_chan->cwd($main::current_targetdir);
1892 # cwd didn't work, channel is closed, try to reopen it
1893 $main::FTP_chan = undef;
1894 } ## end if ($main::FTP_chan)
1901 Debug => $conf::ftpdebug,
1902 Timeout => $conf::ftptimeout,
1908 msg( "log,mail", "Cannot open FTP server $conf::target\n" );
1910 } ## end if ( !( $main::FTP_chan...
1911 if ( !$main::FTP_chan->login() ) {
1912 msg( "log,mail", "Anonymous login on FTP server $conf::target failed\n" );
1915 if ( !$main::FTP_chan->binary() ) {
1916 msg( "log,mail", "Can't set binary FTP mode on $conf::target\n" );
1919 if ( !$main::FTP_chan->cwd($main::current_targetdir) ) {
1921 "Can't cd to $main::current_targetdir on $conf::target\n" );
1924 debug("opened FTP channel to $conf::target");
1928 $main::FTP_chan = undef;
1930 } ## end sub ftp_open()
1935 my $direct_resp_cmd = ( $cmd eq "quot" );
1937 debug( "executing FTP::$cmd(" . join( ", ", @_ ) . ")" );
1938 $SIG{"ALRM"} = sub { die "timeout in FTP::$cmd\n" };
1939 alarm($conf::remote_timeout);
1940 eval { $rv = $main::FTP_chan->$cmd(@_); };
1943 $rv = ( ftp_code() =~ /^2/ ) ? 1 : 0 if $direct_resp_cmd;
1948 $err = ftp_response();
1950 return ( $rv, $err );
1951 } ## end sub ftp_cmd($@)
1954 if ($main::FTP_chan) {
1955 $main::FTP_chan->quit();
1956 $main::FTP_chan = undef;
1959 } ## end sub ftp_close()
1961 sub ftp_response() {
1962 return join( '', @{ ${*$main::FTP_chan}{'net_cmd_resp'} } );
1966 return ${*$main::FTP_chan}{'net_cmd_code'};
1970 my $code = ftp_code();
1971 return ( $code =~ /^[45]/ ) ? 1 : 0;
1974 # ---------------------------------------------------------------------------
1976 # ---------------------------------------------------------------------------
1982 my $ecmd = "$conf::ssh $conf::ssh_options $conf::target "
1983 . "-l $conf::targetlogin \'cd $main::current_targetdir; $cmd\'";
1984 debug("executing $ecmd");
1985 $SIG{"ALRM"} = sub { die "timeout in ssh command\n" };
1986 alarm($conf::remote_timeout);
1987 eval { $msg = `$ecmd 2>&1`; };
1995 return ( $msg, $stat );
1996 } ## end sub ssh_cmd($)
2001 my $ecmd = "$conf::scp $conf::ssh_options @_ "
2002 . "$conf::targetlogin\@$conf::target:$main::current_targetdir";
2003 debug("executing $ecmd");
2004 $SIG{"ALRM"} = sub { die "timeout in scp\n" };
2005 alarm($conf::remote_timeout);
2006 eval { $msg = `$ecmd 2>&1`; };
2014 return ( $msg, $stat );
2015 } ## end sub scp_cmd(@)
2017 sub local_cmd($;$) {
2022 my $ecmd = ( $nocd ? "" : "cd $main::current_targetdir; " ) . $cmd;
2023 debug("executing $ecmd");
2024 $msg = `($ecmd) 2>&1`;
2026 return ( $msg, $stat );
2028 } ## end sub local_cmd($;$)
2031 # check if target is alive (code stolen from Net::Ping.pm)
2033 sub check_alive(;$) {
2034 my $timeout = shift;
2035 my ( $saddr, $ret, $target_ip );
2038 if ( $conf::upload_method eq "copy" ) {
2039 format_status_num( $main::last_ping_time, time );
2040 $main::target_up = 1;
2046 if ( !( $target_ip = ( gethostbyname($conf::target) )[4] ) ) {
2047 msg( "log", "Cannot get IP address of $conf::target\n" );
2051 $saddr = pack( 'S n a4 x8', AF_INET, $main::echo_port, $target_ip );
2052 $SIG{'ALRM'} = sub { die };
2055 $ret = $main::tcp_proto; # avoid warnings about unused variable
2058 return unless socket( PINGSOCK, PF_INET, SOCK_STREAM, $main::tcp_proto );
2059 return unless connect( PINGSOCK, $saddr );
2064 msg( "log", "pinging $conf::target: " . ( $ret ? "ok" : "down" ) . "\n" );
2066 $main::target_up = $ret ? "1" : "0";
2067 format_status_num( $main::last_ping_time, time );
2068 write_status_file() if $conf::statusdelay;
2069 } ## end sub check_alive(;$)
2072 # check if incoming dir on target is writable
2074 sub check_incoming_writable() {
2075 my $testfile = ".debianqueued-testfile";
2078 if ( $conf::upload_method eq "ssh" ) {
2080 ssh_cmd( "rm -f $testfile; touch $testfile; " . "rm -f $testfile" );
2081 } elsif ( $conf::upload_method eq "ftp" ) {
2082 my $file = "junk-for-writable-test-" . format_time();
2083 $file =~ s/[ :.]/-/g;
2085 open( F, ">$file" );
2088 ( $rv, $msg ) = ftp_cmd( "put", $file );
2090 $msg = "" if !defined $msg;
2092 ftp_cmd( "delete", $file );
2093 } elsif ( $conf::upload_method eq "copy" ) {
2095 local_cmd( "rm -f $testfile; touch $testfile; " . "rm -f $testfile" );
2098 debug("exit status: $stat, output was: $msg");
2102 # change incoming_writable only if ssh didn't return an error
2103 $main::incoming_writable =
2104 ( $msg =~ /(permission denied|read-?only file|cannot create)/i )
2108 debug("local error, keeping old status");
2110 debug("incoming_writable = $main::incoming_writable");
2111 write_status_file() if $conf::statusdelay;
2112 return $main::incoming_writable;
2113 } ## end sub check_incoming_writable()
2116 # remove a list of files, log failing ones
2122 ( unlink $_ and ++$done )
2124 or msg( "log", "Could not delete $_: $!\n" );
2130 # get md5 checksum of a file
2136 chomp( $line = `$conf::md5sum $file` );
2137 debug( "md5sum($file): ",
2138 $? ? "exit status $?"
2139 : $line =~ /^(\S+)/ ? $1
2141 return $? ? "" : $line =~ /^(\S+)/ ? $1 : "";
2142 } ## end sub md5sum($)
2145 # check if a file probably belongs to a Debian upload
2147 sub is_debian_file($) {
2149 return $file =~ /\.(deb|dsc|(diff|tar)\.gz)$/
2150 && $file !~ /\.orig\.tar\.gz/;
2154 # try to extract maintainer email address from some a non-.changes file
2155 # return "" if not possible
2157 sub get_maintainer($) {
2159 my $maintainer = "";
2162 if ( $file =~ /\.diff\.gz$/ ) {
2165 open( F, "$conf::gzip -dc '$file' 2>/dev/null |" ) or return "";
2168 # look for header line of a file */debian/control
2169 last if m,^\+\+\+\s+[^/]+/debian/control(\s+|$),;
2172 last if /^---/; # end of control file patch, no Maintainer: found
2173 # inside control file patch look for Maintainer: field
2174 $maintainer = $1, last if /^\+Maintainer:\s*(.*)$/i;
2176 while (<F>) { } # read to end of file to avoid broken pipe
2177 close(F) or return "";
2178 } elsif ( $file =~ /\.(deb|dsc|tar\.gz)$/ ) {
2179 if ( $file =~ /\.deb$/ && $conf::ar ) {
2181 # extract control.tar.gz from .deb with ar, then let tar extract
2182 # the control file itself
2184 "($conf::ar p '$file' control.tar.gz | "
2185 . "$conf::tar -xOf - "
2186 . "--use-compress-program $conf::gzip "
2187 . "control) 2>/dev/null |"
2189 } elsif ( $file =~ /\.dsc$/ ) {
2191 # just do a plain grep
2192 debug("get_maint: .dsc, no cmd");
2193 open( F, "<$file" ) or return "";
2194 } elsif ( $file =~ /\.tar\.gz$/ ) {
2196 # let tar extract a file */debian/control
2198 "$conf::tar -xOf '$file' "
2199 . "--use-compress-program $conf::gzip "
2200 . "\\*/debian/control 2>&1 |"
2206 $maintainer = $1, last if /^Maintainer:\s*(.*)$/i;
2208 close(F) or return "";
2209 } ## end elsif ( $file =~ /\.(deb|dsc|tar\.gz)$/)
2212 } ## end sub get_maintainer($)
2215 # return a pattern that matches all files that probably belong to one job
2217 sub debian_file_stem($) {
2219 my ( $pkg, $version );
2222 $file =~ s,\.(deb|dsc|changes|(orig\.)?tar\.gz|diff\.gz)$,,;
2224 # if not is *_* (name_version), can't derive a stem and return just
2226 return $file if !( $file =~ /^([^_]+)_([^_]+)/ );
2227 ( $pkg, $version ) = ( $1, $2 );
2229 # strip Debian revision from version
2230 $version =~ s/^(.*)-[\d.+-]+$/$1/;
2232 return "${pkg}_${version}*";
2233 } ## end sub debian_file_stem($)
2236 # output a messages to several destinations
2238 # first arg is a comma-separated list of destinations; valid are "log"
2239 # and "mail"; rest is stuff to be printed, just as with print
2242 my @dest = split( ',', shift );
2244 if ( grep /log/, @dest ) {
2245 my $now = format_time();
2246 print LOG "$now ", @_;
2249 if ( grep /mail/, @dest ) {
2250 $main::mail_text .= join( '', @_ );
2252 } ## end sub msg($@)
2255 # print a debug messages, if $debug is true
2258 return if !$conf::debug;
2259 my $now = format_time();
2260 print LOG "$now DEBUG ", @_, "\n";
2264 # intialize the "mail" destination of msg() (this clears text,
2265 # address, subject, ...)
2270 $main::mail_addr = "";
2271 $main::mail_text = "";
2272 %main::packages = ();
2273 $main::mail_subject = $file ? "Processing of $file" : "";
2274 } ## end sub init_mail(;$)
2277 # finalize mail to be sent from msg(): check if something present, and
2282 debug("No mail for $main::mail_addr")
2283 if $main::mail_addr && !$main::mail_text;
2284 return unless $main::mail_addr && $main::mail_text;
2286 if ( !send_mail( $main::mail_addr, $main::mail_subject, $main::mail_text ) )
2289 # store this mail in memory so it isn't lost if executing sendmail
2292 @main::stored_mails,
2294 addr => $main::mail_addr,
2295 subject => $main::mail_subject,
2296 text => $main::mail_text
2299 } ## end if ( !send_mail( $main::mail_addr...
2302 # try to send out stored mails
2304 while ( $mailref = shift(@main::stored_mails) ) {
2306 !send_mail( $mailref->{'addr'}, $mailref->{'subject'},
2307 $mailref->{'text'} )
2310 unshift( @main::stored_mails, $mailref );
2312 } ## end if ( !send_mail( $mailref...
2313 } ## end while ( $mailref = shift(...
2314 } ## end sub finish_mail()
2319 sub send_mail($$$) {
2321 my $subject = shift;
2325 keys %main::packages ? join( ' ', keys %main::packages ) : "";
2329 unless ( defined($Email::Send::Sendmail::SENDMAIL) ) {
2330 $Email::Send::Sendmail::SENDMAIL = $conf::mail;
2333 $addr = 'debian-backports-changes@lists.debian.org';
2334 my $date = sprintf "%s",
2335 strftime( "%a, %d %b %Y %T %z", ( localtime(time) ) );
2336 my $message = <<__MESSAGE__;
2338 From: Archive Administrator <dak\@ftp-master.debian.org>
2344 if ( length $package ) {
2345 $message .= "X-Debian-Package: $package\n";
2348 $message .= "\n$text";
2349 $message .= "\nGreetings,\n\n\tYour Debian queue daemon (running on host $main::hostname)\n";
2351 my $mail = Email::Send->new;
2352 for (qw[Sendmail SMTP]) {
2353 $mail->mailer($_) and last if $mail->mailer_available($_);
2356 my $ret = $mail->send($message);
2357 if ( $ret && $ret !~ /Message sent|success/ ) {
2362 } ## end sub send_mail($$$)
2365 # try to find a mail address for a name in the keyrings
2367 sub try_to_get_mail_addr($$) {
2369 my $listref = shift;
2373 "$conf::gpg --no-options --batch --no-default-keyring "
2374 . "--always-trust --keyring "
2375 . join( " --keyring ", @conf::keyrings )
2379 if ( /^pub / && / $name / ) {
2381 push( @$listref, $1 );
2383 } ## end while (<F>)
2386 return ( @$listref >= 1 ) ? $listref->[0] : "";
2387 } ## end sub try_to_get_mail_addr($$)
2390 # return current time as string
2395 # omit weekday and year for brevity
2396 ( $t = localtime ) =~ /^\w+\s(.*)\s\d+$/;
2398 } ## end sub format_time()
2402 my $hours = int( $secs / ( 60 * 60 ) );
2404 $secs -= $hours * 60 * 60;
2405 return sprintf "%d:%02d:%02d", $hours, int( $secs / 60 ), $secs % 60;
2406 } ## end sub print_time($)
2409 # block some signals during queue processing
2411 # This is just to avoid data inconsistency or uploads being aborted in the
2412 # middle. Only "soft" signals are blocked, i.e. SIGINT and SIGTERM, try harder
2413 # ones if you really want to kill the daemon at once.
2415 sub block_signals() {
2416 POSIX::sigprocmask( SIG_BLOCK, $main::block_sigset );
2419 sub unblock_signals() {
2420 POSIX::sigprocmask( SIG_UNBLOCK, $main::block_sigset );
2424 # process SIGHUP: close log file and reopen it (for logfile cycling)
2431 open( LOG, ">>$conf::logfile" )
2432 or die "Cannot open my logfile $conf::logfile: $!\n";
2433 chmod( 0644, $conf::logfile )
2434 or msg( "log", "Cannot set modes of $conf::logfile: $!\n" );
2435 select( ( select(LOG), $| = 1 )[0] );
2437 open( STDOUT, ">&LOG" )
2439 "$main::progname: Can't redirect stdout to " . "$conf::logfile: $!\n" );
2440 open( STDERR, ">&LOG" )
2442 "$main::progname: Can't redirect stderr to " . "$conf::logfile: $!\n" );
2443 msg( "log", "Restart after SIGHUP\n" );
2444 } ## end sub close_log($)
2447 # process SIGCHLD: check if it was our statusd process
2452 # reap statusd, so that it's no zombie when we try to kill(0) it
2453 waitpid( $main::statusd_pid, WNOHANG );
2455 # Uncomment the following line if your Perl uses unreliable System V signal
2456 # (i.e. if handlers reset to default if the signal is delivered).
2457 # (Unfortunately, the re-setup can't be done in any case, since on some
2458 # systems this will cause the SIGCHLD to be delivered again if there are
2459 # still unreaped children :-(( )
2461 # $SIG{"CHLD"} = \&kid_died; # resetup handler for SysV
2462 } ## end sub kid_died($)
2464 sub restart_statusd() {
2466 # restart statusd if it died
2467 if ( !kill( 0, $main::statusd_pid ) ) {
2468 close(STATUSD); # close out pipe end
2469 $main::statusd_pid = fork_statusd();
2471 } ## end sub restart_statusd()
2474 # process a fatal signal: cleanup and exit
2476 sub fatal_signal($) {
2477 my $signame = shift;
2480 # avoid recursions of fatal_signal in case of BSD signals
2481 foreach $sig (qw( ILL ABRT BUS FPE SEGV PIPE )) {
2482 $SIG{$sig} = "DEFAULT";
2485 if ( $$ == $main::maind_pid ) {
2487 # only the main daemon should do this
2488 kill( $main::signo{"TERM"}, $main::statusd_pid )
2489 if defined $main::statusd_pid;
2490 unlink( $conf::statusfile, $conf::pidfile );
2491 } ## end if ( $$ == $main::maind_pid)
2492 msg( "log", "Caught SIG$signame -- exiting (pid $$)\n" );
2494 } ## end sub fatal_signal($)