Import version as of 2009-10-05 for upload-ftp-v1.1.pl

diff --git a/upload-ftp-v1.1.pl b/upload-ftp-v1.1.pl
index cfd7f8079155ceca34218931883fbf081318ebbd..68ecde3c4bcb9f63a30095e3c93c7b8e430def4d 100755 (executable)
--- a/upload-ftp-v1.1.pl
+++ b/upload-ftp-v1.1.pl
@@ -106,7 +106,9 @@ my $style = '';
 my $help = '';
 my $version = '';
 # Set this to 1 or higher to get debug output in the log file.
-my $DEBUG = 1;
+my $DEBUG = 0;
+
+my $NOMAIL = 0;
 
 GetOptions ("style=s" => \$style, "debug=i" => \$DEBUG, "help" => \$help, "version" => \$version);
 
@@ -433,7 +435,7 @@ sub scan_incoming {
                        if ($racecondition) {
                                # Most likely a race condition. We've found a directive file but not the accompanying file(s).
                                # Just ignore this directive file for now.
-                               ftp_syslog('info',"($log_style) Found directive file with filename directive, but no accompanying files. Ignoring directive file in this run.");
+                               ftp_syslog('info',"($log_style) Found directive file with filename directive ($base), but no accompanying files. Ignoring directive file in this run.");
                        } else {
              # Directive file only, no actual file to deal with
              # This can happen when dealing with symlink/rmsymlink/archive options
@@ -496,8 +498,9 @@ sub email_addresses {
 
        while (<EMAIL_FILE>) {
                chomp;
-               push (@ret, $_)         
-               if $_ =~ /^[[:graph:]]+@[[:graph:]]+$/; # simple sanity check
+    my $line = $_;
+    next if (grep($_ eq $line,@ret) > 0); # Skip duplicates
+               push (@ret, $line)      if $line =~ /^[[:graph:]]+@[[:graph:]]+$/; # simple sanity check
        }
 
        close (EMAIL_FILE) || ftp_warn("close($package_config_base/$package_name/email) failed: $!");
@@ -507,6 +510,9 @@ sub email_addresses {
 sub parse_directory_line {
        my $tainted_val = shift;
        my $directive_file_contents = shift;
+  # $do_not_fail is set to 1 if this sub is called as a last resort in an attempt to find *someone* to report an error to.
+  # When it is set, this sub will not die with &fatal.
+  my $do_not_fail = shift;
   # Can't let it start with  - . /  or contain strange characters.
   # This disallows .. as a file name component since no component
   # can start with a . at all.
@@ -515,16 +521,20 @@ sub parse_directory_line {
       
   # A couple of subdir levels are ok, but don't allow hundreds.
   my $slash_count = ($val =~ tr,/,/,);
-  &fatal("$slash_count slashes is too many, in $val",1,$directive_file_contents) if $slash_count > 3;
-      
+  &fatal("$slash_count slashes is too many, in $val",1,$directive_file_contents) if ($slash_count > 3 and not $do_not_fail);
+
   # Only let them specify one directory directive.
   &fatal("Only one directory directive is allowed per directive file. Error at directory directive: $val",1,$directive_file_contents)
-    if exists $info{"directory"};
+    if (exists $info{"directory"} and not $do_not_fail);
+
 
   $info{"directory"} = $val;  # ok.
   ($info{"package"} = $val) =~ s,/.*$,,;  # top-level name, no subdir
   # Set email addresses
-  push (@{$info{email}}, email_addresses ($info{package}));
+  my @a = email_addresses($info{package});
+  foreach my $address (@a) {
+      push (@{$info{email}}, $address) unless (grep($_ eq $address,@{$info{email}}) > 0); # Do not include duplicates
+  }
 }
 
 \f
@@ -601,7 +611,7 @@ sub read_directive_file {
 
     my ($tainted_cmd,$tainted_val) = split(' ',$line,2);
     if ($tainted_cmd =~ /^Directory:?$/i) {  # case-insensitive, w or w/o the :
-                       parse_directory_line($tainted_val, $directive_file_contents);
+                       parse_directory_line($tainted_val, $directive_file_contents,0);
     } elsif ($tainted_cmd =~ /^Filename:?$/i) {  # case-insensitive, w or w/o the :
       # We use the same filename restrictions as scan_incoming
       $tainted_val =~ /^([\w_\+][-.\w_\+\~]*)$/ || &fatal("invalid filename $tainted_val",1,$directive_file_contents);
@@ -809,9 +819,8 @@ sub read_directive_file {
 
 sub guess_uploader_email {
        my $directive_file_contents = shift;
-
   if ($directive_file_contents =~ /^Directory:? (.*)$/im) {  # case-insensitive, w or w/o the :
-                       parse_directory_line($1, $directive_file_contents);
+                       parse_directory_line($1, $directive_file_contents,1);
        }
 }
 
@@ -834,19 +843,22 @@ sub verify_keyring {
 
                ($verify_str) = $verify_str =~ /^(.*)$/;
 
+    ftp_syslog('info',"$verify_str\n") if ($DEBUG > 0);
        my $retval = `$verify_str`;
 
     if (!defined($retval)) {
                  # This is bad - we couldn't even execute the gpgv command properly
                        guess_uploader_email($directive_file_contents);
-       &fatal("gpg verify of directive file failed: $!",1);
+       &fatal("gpg verify of directive file failed (error executing gpgv): $!",0,'',2);
                } elsif ($retval =~ /\n0\n$/s) { # We store the return value of gpgv on the last line of the output
                  ftp_syslog('info', "($log_style) verified against $_\n");
       return $retval; # We got return value 0 from gpgv -> key verified!
-         }
+         } else {
+                 # gpgv returned an error - most likely just key not found. Ignore, since we are testing all keyrings.
+               }
        }
        guess_uploader_email($directive_file_contents);
-  &fatal("gpg verify of directive file failed",1);
+  &fatal("gpg verify of directive file failed",1,'',2);
 }
 
 \f
@@ -991,17 +1003,16 @@ sub cleanup {
 sub fatal {
   my ($tainted_msg) = shift;
   my ($send_to_user) = shift;
-
        # If we fail before we have sent a copy of the directive file contents to the maintainer
        # (when running in DEBUG mode), that copy is passed along, and we can send it from here.
   my ($directive_file_contents) = shift;
+  my $exit_code = shift;
+
        $directive_file_contents ||= '';
        if (($directive_file_contents ne '') && $DEBUG) {
          &mail ($directive_file_contents,0,"debug: directive file contents");
        }
 
-       print STDERR "$tainted_msg\n";
-
        ftp_syslog('err', "($log_style) $tainted_msg");
 
   # Don't let them do perl or shell quoting tricks, but show everything
@@ -1024,7 +1035,7 @@ sub fatal {
   } else {                     # child
     exec ("/bin/pwd") || ftp_die("can't exec pwd: $!");
   }
-  ftp_die("(in $cwd) $msg");
+  ftp_die("(in $cwd) $msg",$exit_code);
 }
 
 # Used for both success and failure.
@@ -1032,7 +1043,7 @@ sub fatal {
 sub mail {
   my ($msg) = shift;
   my ($send_to_user) = shift;
-       my ($subject) = shift;
+  my ($subject) = shift;
        $subject ||= '';
 
   my @email_list = ($email_always);
@@ -1056,55 +1067,72 @@ sub mail {
   # print STDERR "final emails: @email_list\n";
   # return @_;
 
-  my $smtp = Net::SMTP->new ("127.0.0.1");
-  ftp_die("FATAL: SMTP connection failed") unless $smtp;
-
-  $smtp->mail ($sender);
-  $smtp->bcc ($email_always) if ($send_to_user);
-  $smtp->recipient (@email_list, { SkipBad => 1});
-
-  $smtp->data ();
-  $smtp->datasend ("To: " . join (", ", @email_list) . "\n");
-  $smtp->datasend ("From: $sender\n");
-  $smtp->datasend ("Reply-To: ftp-upload\@gnu.org\n");
-       if ($subject ne '') {
-      $smtp->datasend ("Subject: [gnu-ftp-upload] $subject");
-                       ftp_syslog('info', "($log_style) Subject: '$subject'");
-  } elsif (defined $info{package}) {
-      $smtp->datasend ("Subject: [gnu-ftp-upload] $info{package}");
-                       ftp_syslog('info', "($log_style) Subject: $info{package}");
+  if ($NOMAIL) {
+       if ($subject ne '') {
+                       ftp_syslog('info', "($log_style) Subject: '$subject'");
+      } elsif (defined $info{package}) {
+                       ftp_syslog('info', "($log_style) Subject: $info{package}");
+      } else {
+                       ftp_syslog('warning', "($log_style) Error uploading package: $msg");
+                       ftp_syslog('info', "($log_style) Subject: generic failure");
+      }
+      ftp_syslog('info', "($log_style) Body: $msg");
   } else {
-      $smtp->datasend ("Subject: [gnu-ftp-upload] generic failure");
-                       ftp_syslog('warning', "($log_style) Error uploading package: $msg");
-                       ftp_syslog('info', "($log_style) Subject: generic failure");
-  }
-  $smtp->datasend ("\n\n");
-  ftp_syslog('info', "($log_style) Body: $msg");
-
-  # Wrap message at 78 characters, this is e-mail...
-  $Text::Wrap::columns=78;
-  $smtp->datasend (wrap('','',$msg) . "\n");
-  $smtp->dataend ();
+      my $smtp = Net::SMTP->new ("127.0.0.1");
+      ftp_die("FATAL: SMTP connection failed") unless $smtp;
 
-  $smtp->quit ();
+      $smtp->mail ($sender);
+      $smtp->bcc ($email_always) if ($send_to_user);
+      $smtp->recipient (@email_list, { SkipBad => 1});
+    
+      $smtp->data ();
+      $smtp->datasend ("To: " . join (", ", @email_list) . "\n");
+      $smtp->datasend ("From: $sender\n");
+      $smtp->datasend ("Reply-To: ftp-upload\@gnu.org\n");
+       if ($subject ne '') {
+          $smtp->datasend ("Subject: [gnu-ftp-upload] $subject");
+                       ftp_syslog('info', "($log_style) Subject: '$subject'");
+      } elsif (defined $info{package}) {
+          $smtp->datasend ("Subject: [gnu-ftp-upload] $info{package}");
+                       ftp_syslog('info', "($log_style) Subject: $info{package}");
+      } else {
+          $smtp->datasend ("Subject: [gnu-ftp-upload] generic failure");
+                       ftp_syslog('warning', "($log_style) Error uploading package: $msg");
+                       ftp_syslog('info', "($log_style) Subject: generic failure");
+      }
+      $smtp->datasend ("\n\n");
+      ftp_syslog('info', "($log_style) Body: $msg");
+    
+      # Wrap message at 78 characters, this is e-mail...
+      $Text::Wrap::columns=78;
+      $smtp->datasend (wrap('','',$msg) . "\n");
+      $smtp->dataend ();
+    
+      $smtp->quit ();
+    }
 }
 
 sub debug {
        my $msg = shift;
-  my $smtp = Net::SMTP->new ("127.0.0.1");
-  ftp_die("FATAL: SMTP connection failed") unless $smtp;
-  $smtp->mail ("ftp-upload-script\@gnu.org");
-  $smtp->recipient ($maintainer_email, { SkipBad => 1});
-
-  $smtp->data ();
-  $smtp->datasend ("To: $maintainer_email\n");
-  $smtp->datasend ("From: ftp-upload-script\@gnu.org\n");
-  $smtp->datasend ("Reply-To: ftp-upload\@gnu.org\n");
-  $smtp->datasend ("Subject: [$m_style gnu-ftp-debug] new upload processed");
-  $smtp->datasend ("\n\n");
-  $smtp->datasend ("$msg\n");
-  $smtp->dataend ();
-  $smtp->quit ();
+
+  if ($NOMAIL) {
+      ftp_syslog('info', "($log_style) Subject: [$m_style gnu-ftp-debug] new upload processed\nBody: $msg");
+  } else {
+      my $smtp = Net::SMTP->new ("127.0.0.1");
+      ftp_die("FATAL: SMTP connection failed") unless $smtp;
+      $smtp->mail ("ftp-upload-script\@gnu.org");
+      $smtp->recipient ($maintainer_email, { SkipBad => 1});
+    
+      $smtp->data ();
+      $smtp->datasend ("To: $maintainer_email\n");
+      $smtp->datasend ("From: ftp-upload-script\@gnu.org\n");
+      $smtp->datasend ("Reply-To: ftp-upload\@gnu.org\n");
+      $smtp->datasend ("Subject: [$m_style gnu-ftp-debug] new upload processed");
+      $smtp->datasend ("\n\n");
+      $smtp->datasend ("$msg\n");
+      $smtp->dataend ();
+      $smtp->quit ();
+  }
 }
 
 sub ftp_warn($) {
@@ -1112,9 +1140,12 @@ sub ftp_warn($) {
     warn $_[0];
 }
 
-sub ftp_die($) {
-    ftp_syslog('err', "($log_style) " . $_[0]);
-    exit 1;
+sub ftp_die($$) {
+    my $msg = shift;
+    my $exitcode = shift;
+    $exitcode ||= 1;
+    ftp_syslog('err', "($log_style) " . $msg);
+    exit $exitcode;
 }
 
 sub ftp_syslog {