- my $changes = shift;
- my $keep_list = shift;
- my( $pgplines, @files, @filenames, @changes_stats, $failure_file,
- $retries, $last_retry, $upload_time, $file, $do_report, $ls_l,
- $problems_reported, $errs, $pkgname, $signator );
- local( *CHANGES );
- local( *FAILS );
-
- format_status_str( $main::current_changes, $changes );
- $main::dstat = "c";
- write_status_file() if $conf::statusdelay;
-
- @$keep_list = ();
- msg( "log", "processing $changes\n" );
-
- # parse the .changes file
- open( CHANGES, "<$changes" )
- or die "Cannot open $changes: $!\n";
- $pgplines = 0;
- $main::mail_addr = "";
- @files = ();
- outer_loop: while( <CHANGES> ) {
- if (/^---+(BEGIN|END) PGP .*---+$/) {
- ++$pgplines;
- }
- elsif (/^Maintainer:\s*/i) {
- chomp( $main::mail_addr = $' );
- $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
- }
- elsif (/^Source:\s*/i) {
- chomp( $pkgname = $' );
- $pkgname =~ s/\s+$//;
- }
- elsif (/^Files:/i) {
- while( <CHANGES> ) {
- redo outer_loop if !/^\s/;
- my @field = split( /\s+/ );
- next if @field != 6;
- # forbid shell meta chars in the name, we pass it to a
- # subshell several times...
- $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/;
- if ($1 ne $field[5]) {
- msg( "log", "found suspicious filename $field[5]\n" );
- msg( "mail", "File '$field[5]' mentioned in $changes\n",
- "has bad characters in its name. Removed.\n" );
- rm( $field[5] );
- next;
- }
- push( @files, { md5 => $field[1],
- size => $field[2],
- name => $field[5] } );
- push( @filenames, $field[5] );
- debug( "includes file $field[5], size $field[2], ",
- "md5 $field[1]" );
- }
- }
- }
- close( CHANGES );
-
- # tell check_dir that the files mentioned in this .changes aren't stray,
- # we know about them somehow
- @$keep_list = @filenames;
-
- # some consistency checks
- if (!$main::mail_addr) {
- msg( "log,mail", "$changes doesn't contain a Maintainer: field; ".
- "cannot process\n" );
- goto remove_only_changes;
- }
- if ($main::mail_addr !~ /^(buildd_\S+-\S+|\S+\@\S+\.\S+)/) {
- # doesn't look like a mail address, maybe only the name
- my( $new_addr, @addr_list );
- if ($new_addr = try_to_get_mail_addr( $main::mail_addr, \@addr_list )){
- # substitute (unique) found addr, but give a warning
- msg( "mail", "(The Maintainer: field didn't contain a proper ".
- "mail address.\n" );
- msg( "mail", "Looking for `$main::mail_addr' in the Debian ".
- "keyring gave your address\n" );
- msg( "mail", "as unique result, so I used this.)\n" );
- msg( "log", "Substituted $new_addr for malformed ".
- "$main::mail_addr\n" );
- $main::mail_addr = $new_addr;
- }
- else {
- # not found or not unique: hold the job and inform queue maintainer
- my $old_addr = $main::mail_addr;
- $main::mail_addr = $conf::maintainer_mail;
- msg( "mail", "The job $changes doesn't have a correct email\n" );
- msg( "mail", "address in the Maintainer: field:\n" );
- msg( "mail", " $old_addr\n" );
- msg( "mail", "A check for this in the Debian keyring gave:\n" );
- msg( "mail", @addr_list ?
- " " . join( ", ", @addr_list ) . "\n" :
- " nothing\n" );
- msg( "mail", "Please fix this manually\n" );
- msg( "log", "Bad Maintainer: field in $changes: $old_addr\n" );
- goto remove_only_changes;
- }
- }
- if ($pgplines < 3) {
- msg( "log,mail", "$changes isn't signed with PGP/GnuPG\n" );
- msg( "log", "(uploader $main::mail_addr)\n" );
- goto remove_only_changes;
- }
- if (!@files) {
- msg( "log,mail", "$changes doesn't mention any files\n" );
- msg( "log", "(uploader $main::mail_addr)\n" );
- goto remove_only_changes;
- }
-
- # check for packages that shouldn't be processed
- if (grep( $_ eq $pkgname, @conf::nonus_packages )) {
- msg( "log,mail", "$pkgname is a package that must be uploaded ".
- "to nonus.debian.org\n" );
- msg( "log,mail", "instead of target.\n" );
- msg( "log,mail", "Job rejected and removed all files belonging ".
- "to it:\n" );
- msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
- rm( $changes, @filenames );
- return;
- }
-
- $failure_file = $changes . ".failures";
- $retries = $last_retry = 0;
- if (-f $failure_file) {
- open( FAILS, "<$failure_file" )
- or die "Cannot open $failure_file: $!\n";
- my $line = <FAILS>;
- close( FAILS );
- ( $retries, $last_retry ) = ( $1, $2 ) if $line =~ /^(\d+)\s+(\d+)$/;
- push( @$keep_list, $failure_file );
- }
-
- # run PGP on the file to check the signature
- if (!($signator = pgp_check( $changes ))) {
- msg( "log,mail", "$changes has bad PGP/GnuPG signature!\n" );
- msg( "log", "(uploader $main::mail_addr)\n" );
- remove_only_changes:
- msg( "log,mail", "Removing $changes, but keeping its associated ",
- "files for now.\n" );
- rm( $changes );
- # Set SGID bit on associated files, so that the test for Debian files
- # without a .changes doesn't consider them.
- foreach ( @filenames ) {
- my @st = stat($_);
- next if !@st; # file may have disappeared in the meantime
- chmod +($st[ST_MODE] |= S_ISGID), $_;
- }
- return;
- }
- elsif ($signator eq "LOCAL ERROR") {
- # An error has appened when starting pgp... Don't process the file,
- # but also don't delete it
- debug( "Can't PGP/GnuPG check $changes -- don't process it for now" );
- return;
- }
-
- die "Cannot stat $changes (??): $!\n"
- if !(@changes_stats = stat( $changes ));
- # Make $upload_time the maximum of all modification times of files
- # related to this .changes (and the .changes it self). This is the
- # last time something changes to these files.
- $upload_time = $changes_stats[ST_MTIME];
- for $file ( @files ) {
- my @stats;
- next if !(@stats = stat( $file->{"name"} ));
- $file->{"stats"} = \@stats;
- $upload_time = $stats[ST_MTIME] if $stats[ST_MTIME] > $upload_time;
- }
-
- $do_report = (time - $upload_time) > $conf::problem_report_timeout;
- $problems_reported = $changes_stats[ST_MODE] & S_ISGID;
- # if any of the files is newer than the .changes' ctime (the time
- # we sent a report and set the sticky bit), send new problem reports
- if ($problems_reported && $changes_stats[ST_CTIME] < $upload_time) {
- $problems_reported = 0;
- chmod +($changes_stats[ST_MODE] &= ~S_ISGID), $changes;
- debug( "upload_time>changes-ctime => resetting problems reported" );
- }
- debug( "do_report=$do_report problems_reported=$problems_reported" );
-
- # now check all files for correct size and md5 sum
- for $file ( @files ) {
- my $filename = $file->{"name"};
- if (!defined( $file->{"stats"} )) {
- # could be an upload that isn't complete yet, be quiet,
- # but don't process the file;
- msg( "log,mail", "$filename doesn't exist\n" )
- if $do_report && !$problems_reported;
- msg( "log", "$filename doesn't exist (ignored for now)\n" )
- if !$do_report;
- msg( "log", "$filename doesn't exist (already reported)\n" )
- if $problems_reported;
- ++$errs;
- }
- elsif ($file->{"stats"}->[ST_SIZE] < $file->{"size"} && !$do_report) {
- # could be an upload that isn't complete yet, be quiet,
- # but don't process the file
- msg( "log", "$filename is too small (ignored for now)\n" );
- ++$errs;
- }
- elsif ($file->{"stats"}->[ST_SIZE] != $file->{"size"}) {
- msg( "log,mail", "$filename has incorrect size; deleting it\n" );
- rm( $filename );
- ++$errs;
- }
- elsif (md5sum( $filename ) ne $file->{"md5"}) {
- msg( "log,mail", "$filename has incorrect md5 checksum; ",
- "deleting it\n" );
- rm( $filename );
- ++$errs;
- }
- }
-
- if ($errs) {
- if ((time - $upload_time) > $conf::bad_changes_timeout) {
- # if a .changes fails for a really long time (several days
- # or so), remove it and all associated files
- msg( "log,mail",
- "$changes couldn't be processed for ",
- int($conf::bad_changes_timeout/(60*60)),
- " hours and is now deleted\n" );
- msg( "log,mail",
- "All files it mentions are also removed:\n" );
- msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
- rm( $changes, @filenames, $failure_file );
- }
- elsif ($do_report && !$problems_reported) {
- # otherwise, send a problem report, if not done already
- msg( "mail",
- "Due to the errors above, the .changes file couldn't ",
- "be processed.\n",
- "Please fix the problems for the upload to happen.\n" );
- # remember we already have sent a mail regarding this file
- debug( "Sending problem report mail and setting SGID bit" );
- my $mode = $changes_stats[ST_MODE] |= S_ISGID;
- msg( "log", "chmod failed: $!" ) if (chmod ($mode, $changes) != 1);
- }
- # else: be quiet
-
- return;
- }
-
- # if this upload already failed earlier, wait until the delay requirement
- # is fulfilled
- if ($retries > 0 && (time - $last_retry) <
- ($retries == 1 ? $conf::upload_delay_1 : $conf::upload_delay_2)) {
- msg( "log", "delaying retry of upload\n" );
- return;
- }
-
- if ($conf::upload_method eq "ftp") {
- return if !ftp_open();
- }
-
- # check if the job is already present on target
- # (moved to here, to avoid bothering target as long as there are errors in
- # the job)
- if ($ls_l = is_on_target( $changes )) {
- msg( "log,mail", "$changes is already present on target host:\n" );
- msg( "log,mail", "$ls_l\n" );
- msg( "mail", "Either you already uploaded it, or someone else ",
- "came first.\n" );
- msg( "log,mail", "Job $changes removed.\n" );
- rm( $changes, @filenames, $failure_file );
- return;
- }
-
- # clear sgid bit before upload, scp would copy it to target. We don't need
- # it anymore, we know there are no problems if we come here. Also change
- # mode of files to 644 if this should be done locally.
- $changes_stats[ST_MODE] &= ~S_ISGID;
- if (!$conf::chmod_on_target) {
- $changes_stats[ST_MODE] &= ~0777;
- $changes_stats[ST_MODE] |= 0644;
- }
- chmod +($changes_stats[ST_MODE]), $changes;
-
- # try uploading to target
- if (!copy_to_target( $changes, @filenames )) {
- # if the upload failed, increment the retry counter and remember the
- # current time; both things are written to the .failures file. Don't
- # increment the fail counter if the error was due to incoming
- # unwritable.
- return if !$main::incoming_writable;
- if (++$retries >= $conf::max_upload_retries) {
- msg( "log,mail",
- "$changes couldn't be uploaded for $retries times now.\n" );
- msg( "log,mail",
- "Giving up and removing it and its associated files:\n" );
- msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
- rm( $changes, @filenames, $failure_file );
- }
- else {
- $last_retry = time;
- if (open( FAILS, ">$failure_file" )) {
- print FAILS "$retries $last_retry\n";
- close( FAILS );
- chmod( 0600, $failure_file )
- or die "Cannot set modes of $failure_file: $!\n";
- }
- push( @$keep_list, $failure_file );
- debug( "now $retries failed uploads" );
- msg( "mail",
- "The upload will be retried in ",
- print_time( $retries == 1 ? $conf::upload_delay_1 :
- $conf::upload_delay_2 ), "\n" );
- }
- return;
- }
-
- # If the files were uploaded ok, remove them
- rm( $changes, @filenames, $failure_file );
-
- msg( "mail", "$changes uploaded successfully to $conf::target\n" );
- msg( "mail", "along with the files:\n ",
- join( "\n ", @filenames ), "\n" );
- msg( "log", "$changes processed successfully (uploader $main::mail_addr)\n" );
-
- # Check for files that have the same stem as the .changes (and weren't
- # mentioned there) and delete them. It happens often enough that people
- # upload a .orig.tar.gz where it isn't needed and also not in the
- # .changes. Explicitly deleting it (and not waiting for the
- # $stray_remove_timeout) reduces clutter in the queue dir and maybe also
- # educates uploaders :-)
-
-# my $pattern = debian_file_stem( $changes );
-# my $spattern = substr( $pattern, 0, -1 ); # strip off '*' at end
-# my @other_files = glob($pattern);
- # filter out files that have a Debian revision at all and a different
- # revision. Those belong to a different upload.
-# if ($changes =~ /^\Q$spattern\E-([\d.+-]+)/) {
-# my $this_rev = $1;
-# @other_files = grep( !/^\Q$spattern\E-([\d.+-]+)/ || $1 eq $this_rev,
-# @other_files);
- #}
- # Also do not remove those files if a .changes is among them. Then there
- # is probably a second upload for another version or another architecture.
-# if (@other_files && !grep( /\.changes$/, @other_files )) {
-# rm( @other_files );
-# msg( "mail", "\nThe following file(s) seemed to belong to the same ".
-# "upload, but weren't listed\n" );
-# msg( "mail", "in the .changes file:\n " );
-# msg( "mail", join( "\n ", @other_files ), "\n" );
-# msg( "mail", "They have been deleted.\n" );
-# msg( "log", "Deleted files in upload not in $changes: @other_files\n" );
- #}
-}
+ my $changes = shift;
+ my $keep_list = shift;
+ my (
+ $pgplines, @files, @filenames, @changes_stats,
+ $failure_file, $retries, $last_retry, $upload_time,
+ $file, $do_report, $ls_l, $problems_reported,
+ $errs, $pkgname, $signator
+ );
+ local (*CHANGES);
+ local (*FAILS);
+
+ format_status_str( $main::current_changes,
+ "$main::current_incoming_short/$changes" );
+ $main::dstat = "c";
+ write_status_file() if $conf::statusdelay;
+
+ @$keep_list = ();
+ msg( "log", "processing ${main::current_incoming_short}/$changes\n" );
+
+ # parse the .changes file
+ open( CHANGES, "<$changes" )
+ or die "Cannot open ${main::current_incoming_short}/$changes: $!\n";
+ $pgplines = 0;
+ $main::mail_addr = "";
+ @files = ();
+outer_loop: while (<CHANGES>) {
+ if (/^---+(BEGIN|END) PGP .*---+$/) {
+ ++$pgplines;
+ } elsif (/^Maintainer:\s*/i) {
+ chomp( $main::mail_addr = $' );
+ $main::mail_addr = $1 if $main::mail_addr =~ /<([^>]*)>/;
+ } elsif (/^Source:\s*/i) {
+ chomp( $pkgname = $' );
+ $pkgname =~ s/\s+$//;
+ $main::packages{$pkgname}++;
+ } elsif (/^Files:/i) {
+ while (<CHANGES>) {
+ redo outer_loop if !/^\s/;
+ my @field = split(/\s+/);
+ next if @field != 6;
+
+ # forbid shell meta chars in the name, we pass it to a
+ # subshell several times...
+ $field[5] =~ /^([a-zA-Z0-9.+_:@=%-][~a-zA-Z0-9.+_:@=%-]*)/;
+ if ( $1 ne $field[5] ) {
+ msg( "log", "found suspicious filename $field[5]\n" );
+ msg(
+ "mail",
+"File '$field[5]' mentioned in $main::current_incoming_short/$changes\n",
+ "has bad characters in its name. Removed.\n"
+ );
+ rm( $field[5] );
+ next;
+ } ## end if ( $1 ne $field[5] )
+ push(
+ @files,
+ {
+ md5 => $field[1],
+ size => $field[2],
+ name => $field[5]
+ }
+ );
+ push( @filenames, $field[5] );
+ debug( "includes file $field[5], size $field[2], ", "md5 $field[1]" );
+ } ## end while (<CHANGES>)
+ } ## end elsif (/^Files:/i)
+ } ## end while (<CHANGES>)
+ close(CHANGES);
+
+ # tell check_dir that the files mentioned in this .changes aren't stray,
+ # we know about them somehow
+ @$keep_list = @filenames;
+
+ # some consistency checks
+ if ( !$main::mail_addr ) {
+ msg( "log,mail",
+"$main::current_incoming_short/$changes doesn't contain a Maintainer: field; "
+ . "cannot process\n" );
+ goto remove_only_changes;
+ } ## end if ( !$main::mail_addr)
+ if ( $main::mail_addr !~ /^(buildd_\S+-\S+|\S+\@\S+\.\S+)/ ) {
+
+ # doesn't look like a mail address, maybe only the name
+ my ( $new_addr, @addr_list );
+ if ( $new_addr = try_to_get_mail_addr( $main::mail_addr, \@addr_list ) ) {
+
+ # substitute (unique) found addr, but give a warning
+ msg(
+ "mail",
+ "(The Maintainer: field didn't contain a proper "
+ . "mail address.\n"
+ );
+ msg(
+ "mail",
+ "Looking for `$main::mail_addr' in the Debian "
+ . "keyring gave your address\n"
+ );
+ msg( "mail", "as unique result, so I used this.)\n" );
+ msg( "log",
+ "Substituted $new_addr for malformed " . "$main::mail_addr\n" );
+ $main::mail_addr = $new_addr;
+ } else {
+
+ # not found or not unique: hold the job and inform queue maintainer
+ my $old_addr = $main::mail_addr;
+ $main::mail_addr = $conf::maintainer_mail;
+ msg(
+ "mail",
+"The job ${main::current_incoming_short}/$changes doesn't have a correct email\n"
+ );
+ msg( "mail", "address in the Maintainer: field:\n" );
+ msg( "mail", " $old_addr\n" );
+ msg( "mail", "A check for this in the Debian keyring gave:\n" );
+ msg( "mail",
+ @addr_list
+ ? " " . join( ", ", @addr_list ) . "\n"
+ : " nothing\n" );
+ msg( "mail", "Please fix this manually\n" );
+ msg(
+ "log",
+"Bad Maintainer: field in ${main::current_incoming_short}/$changes: $old_addr\n"
+ );
+ goto remove_only_changes;
+ } ## end else [ if ( $new_addr = try_to_get_mail_addr...
+ } ## end if ( $main::mail_addr ...
+ if ( $pgplines < 3 ) {
+ msg(
+ "log,mail",
+ "$main::current_incoming_short/$changes isn't signed with PGP/GnuPG\n"
+ );
+ msg( "log", "(uploader $main::mail_addr)\n" );
+ goto remove_only_changes;
+ } ## end if ( $pgplines < 3 )
+ if ( !@files ) {
+ msg( "log,mail",
+ "$main::current_incoming_short/$changes doesn't mention any files\n" );
+ msg( "log", "(uploader $main::mail_addr)\n" );
+ goto remove_only_changes;
+ } ## end if ( !@files )
+
+ # check for packages that shouldn't be processed
+ if ( grep( $_ eq $pkgname, @conf::nonus_packages ) ) {
+ msg(
+ "log,mail",
+ "$pkgname is a package that must be uploaded "
+ . "to nonus.debian.org\n"
+ );
+ msg( "log,mail", "instead of target.\n" );
+ msg( "log,mail",
+ "Job rejected and removed all files belonging " . "to it:\n" );
+ msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
+ rm( $changes, @filenames );
+ return;
+ } ## end if ( grep( $_ eq $pkgname...
+
+ $failure_file = $changes . ".failures";
+ $retries = $last_retry = 0;
+ if ( -f $failure_file ) {
+ open( FAILS, "<$failure_file" )
+ or die "Cannot open $main::current_incoming_short/$failure_file: $!\n";
+ my $line = <FAILS>;
+ close(FAILS);
+ ( $retries, $last_retry ) = ( $1, $2 )
+ if $line =~ /^(\d+)\s+(\d+)$/;
+ push( @$keep_list, $failure_file );
+ } ## end if ( -f $failure_file )
+
+ # run PGP on the file to check the signature
+ if ( !( $signator = pgp_check($changes) ) ) {
+ msg(
+ "log,mail",
+ "$main::current_incoming_short/$changes has bad PGP/GnuPG signature!\n"
+ );
+ msg( "log", "(uploader $main::mail_addr)\n" );
+ remove_only_changes:
+ msg(
+ "log,mail",
+"Removing $main::current_incoming_short/$changes, but keeping its associated ",
+ "files for now.\n"
+ );
+ rm($changes);
+
+ # Set SGID bit on associated files, so that the test for Debian files
+ # without a .changes doesn't consider them.
+ foreach (@filenames) {
+ my @st = stat($_);
+ next if !@st; # file may have disappeared in the meantime
+ chmod +( $st[ST_MODE] |= S_ISGID ), $_;
+ }
+ return;
+ } elsif ( $signator eq "LOCAL ERROR" ) {
+
+ # An error has appened when starting pgp... Don't process the file,
+ # but also don't delete it
+ debug(
+"Can't PGP/GnuPG check $main::current_incoming_short/$changes -- don't process it for now"
+ );
+ return;
+ } ## end elsif ( $signator eq "LOCAL ERROR")
+
+ die "Cannot stat ${main::current_incoming_short}/$changes (??): $!\n"
+ if !( @changes_stats = stat($changes) );
+
+ # Make $upload_time the maximum of all modification times of files
+ # related to this .changes (and the .changes it self). This is the
+ # last time something changes to these files.
+ $upload_time = $changes_stats[ST_MTIME];
+ for $file (@files) {
+ my @stats;
+ next if !( @stats = stat( $file->{"name"} ) );
+ $file->{"stats"} = \@stats;
+ $upload_time = $stats[ST_MTIME] if $stats[ST_MTIME] > $upload_time;
+ } ## end for $file (@files)
+
+ $do_report = ( time - $upload_time ) > $conf::problem_report_timeout;
+ $problems_reported = $changes_stats[ST_MODE] & S_ISGID;
+
+ # if any of the files is newer than the .changes' ctime (the time
+ # we sent a report and set the sticky bit), send new problem reports
+ if ( $problems_reported && $changes_stats[ST_CTIME] < $upload_time ) {
+ $problems_reported = 0;
+ chmod +( $changes_stats[ST_MODE] &= ~S_ISGID ), $changes;
+ debug("upload_time>changes-ctime => resetting problems reported");
+ }
+ debug("do_report=$do_report problems_reported=$problems_reported");
+
+ # now check all files for correct size and md5 sum
+ for $file (@files) {
+ my $filename = $file->{"name"};
+ if ( !defined( $file->{"stats"} ) ) {
+
+ # could be an upload that isn't complete yet, be quiet,
+ # but don't process the file;
+ msg( "log,mail", "$filename doesn't exist\n" )
+ if $do_report && !$problems_reported;
+ msg( "log", "$filename doesn't exist (ignored for now)\n" )
+ if !$do_report;
+ msg( "log", "$filename doesn't exist (already reported)\n" )
+ if $problems_reported;
+ ++$errs;
+ } elsif ( $file->{"stats"}->[ST_SIZE] < $file->{"size"}
+ && !$do_report )
+ {
+
+ # could be an upload that isn't complete yet, be quiet,
+ # but don't process the file
+ msg( "log", "$filename is too small (ignored for now)\n" );
+ ++$errs;
+ } elsif ( $file->{"stats"}->[ST_SIZE] != $file->{"size"} ) {
+ msg( "log,mail", "$filename has incorrect size; deleting it\n" );
+ rm($filename);
+ ++$errs;
+ } elsif ( md5sum($filename) ne $file->{"md5"} ) {
+ msg( "log,mail",
+ "$filename has incorrect md5 checksum; ",
+ "deleting it\n" );
+ rm($filename);
+ ++$errs;
+ } ## end elsif ( md5sum($filename)...
+ } ## end for $file (@files)
+
+ if ($errs) {
+ if ( ( time - $upload_time ) > $conf::bad_changes_timeout ) {
+
+ # if a .changes fails for a really long time (several days
+ # or so), remove it and all associated files
+ msg(
+ "log,mail",
+ "$main::current_incoming_short/$changes couldn't be processed for ",
+ int( $conf::bad_changes_timeout / ( 60 * 60 ) ),
+ " hours and is now deleted\n"
+ );
+ msg( "log,mail", "All files it mentions are also removed:\n" );
+ msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
+ rm( $changes, @filenames, $failure_file );
+ } elsif ( $do_report && !$problems_reported ) {
+
+ # otherwise, send a problem report, if not done already
+ msg(
+ "mail",
+ "Due to the errors above, the .changes file couldn't ",
+ "be processed.\n",
+ "Please fix the problems for the upload to happen.\n"
+ );
+
+ # remember we already have sent a mail regarding this file
+ debug("Sending problem report mail and setting SGID bit");
+ my $mode = $changes_stats[ST_MODE] |= S_ISGID;
+ msg( "log", "chmod failed: $!" )
+ if ( chmod( $mode, $changes ) != 1 );
+ } ## end elsif ( $do_report && !$problems_reported)
+
+ # else: be quiet
+
+ return;
+ } ## end if ($errs)
+
+ # if this upload already failed earlier, wait until the delay requirement
+ # is fulfilled
+ if ( $retries > 0
+ && ( time - $last_retry ) <
+ ( $retries == 1 ? $conf::upload_delay_1 : $conf::upload_delay_2 ) )
+ {
+ msg( "log", "delaying retry of upload\n" );
+ return;
+ } ## end if ( $retries > 0 && (...
+
+ if ( $conf::upload_method eq "ftp" ) {
+ return if !ftp_open();
+ }
+
+ # check if the job is already present on target
+ # (moved to here, to avoid bothering target as long as there are errors in
+ # the job)
+ if ( $ls_l = is_on_target( $changes, @filenames ) ) {
+ msg(
+ "log,mail",
+"$main::current_incoming_short/$changes is already present on target host:\n"
+ );
+ msg( "log,mail", "$ls_l\n" );
+ msg( "mail",
+ "Either you already uploaded it, or someone else ",
+ "came first.\n" );
+ msg( "log,mail", "Job $changes removed.\n" );
+ rm( $changes, @filenames, $failure_file );
+ return;
+ } ## end if ( $ls_l = is_on_target...
+
+ # clear sgid bit before upload, scp would copy it to target. We don't need
+ # it anymore, we know there are no problems if we come here. Also change
+ # mode of files to 644 if this should be done locally.
+ $changes_stats[ST_MODE] &= ~S_ISGID;
+ if ( !$conf::chmod_on_target ) {
+ $changes_stats[ST_MODE] &= ~0777;
+ $changes_stats[ST_MODE] |= 0644;
+ }
+ chmod +( $changes_stats[ST_MODE] ), $changes;
+
+ # try uploading to target
+ if ( !copy_to_target( $changes, @filenames ) ) {
+
+ # if the upload failed, increment the retry counter and remember the
+ # current time; both things are written to the .failures file. Don't
+ # increment the fail counter if the error was due to incoming
+ # unwritable.
+ return if !$main::incoming_writable;
+ if ( ++$retries >= $conf::max_upload_retries ) {
+ msg( "log,mail",
+ "$changes couldn't be uploaded for $retries times now.\n" );
+ msg( "log,mail",
+ "Giving up and removing it and its associated files:\n" );
+ msg( "log,mail", " ", join( ", ", @filenames ), "\n" );
+ rm( $changes, @filenames, $failure_file );
+ } else {
+ $last_retry = time;
+ if ( open( FAILS, ">$failure_file" ) ) {
+ print FAILS "$retries $last_retry\n";
+ close(FAILS);
+ chmod( 0600, $failure_file )
+ or die "Cannot set modes of $failure_file: $!\n";
+ } ## end if ( open( FAILS, ">$failure_file"...
+ push( @$keep_list, $failure_file );
+ debug("now $retries failed uploads");
+ msg(
+ "mail",
+ "The upload will be retried in ",
+ print_time(
+ $retries == 1
+ ? $conf::upload_delay_1
+ : $conf::upload_delay_2
+ ),
+ "\n"
+ );
+ } ## end else [ if ( ++$retries >= $conf::max_upload_retries)
+ return;
+ } ## end if ( !copy_to_target( ...
+
+ # If the files were uploaded ok, remove them
+ rm( $changes, @filenames, $failure_file );
+
+ msg( "mail", "$changes uploaded successfully to $conf::target\n" );
+ msg( "mail", "along with the files:\n ", join( "\n ", @filenames ),
+ "\n" );
+ msg( "log",
+ "$changes processed successfully (uploader $main::mail_addr)\n" );
+
+ # Check for files that have the same stem as the .changes (and weren't
+ # mentioned there) and delete them. It happens often enough that people
+ # upload a .orig.tar.gz where it isn't needed and also not in the
+ # .changes. Explicitly deleting it (and not waiting for the
+ # $stray_remove_timeout) reduces clutter in the queue dir and maybe also
+ # educates uploaders :-)
+
+ # my $pattern = debian_file_stem( $changes );
+ # my $spattern = substr( $pattern, 0, -1 ); # strip off '*' at end
+ # my @other_files = glob($pattern);
+ # filter out files that have a Debian revision at all and a different
+ # revision. Those belong to a different upload.
+ # if ($changes =~ /^\Q$spattern\E-([\d.+-]+)/) {
+ # my $this_rev = $1;
+ # @other_files = grep( !/^\Q$spattern\E-([\d.+-]+)/ || $1 eq $this_rev,
+ # @other_files);
+ #}
+ # Also do not remove those files if a .changes is among them. Then there
+ # is probably a second upload for another version or another architecture.
+ # if (@other_files && !grep( /\.changes$/, @other_files )) {
+ # rm( @other_files );
+ # msg( "mail", "\nThe following file(s) seemed to belong to the same ".
+ # "upload, but weren't listed\n" );
+ # msg( "mail", "in the .changes file:\n " );
+ # msg( "mail", join( "\n ", @other_files ), "\n" );
+ # msg( "mail", "They have been deleted.\n" );
+ # msg( "log", "Deleted files in upload not in $changes: @other_files\n" );
+ #}
+} ## end sub process_changes($\@)