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