Factor element-processing loop out of read_directive_file

diff --git a/gatekeeper.pl b/gatekeeper.pl
index 58002b2c67afa99278afdca116b5c80cc93a609b..b45c806e49b1ad649d784037a36963ca26447f1e 100755 (executable)
--- a/gatekeeper.pl
+++ b/gatekeeper.pl
@@ -1267,48 +1267,21 @@ sub verify_keyring {
 # We assume DIRECTIVE_FILE is clear-signed (gpg --clearsign).  Among
 # other things, this lets us use gpgv everywhere, for paranoia's sake.
 #
-sub read_directive_file {
-  my $directive_file = shift;
-  my $uploaded_file = shift;
-  my $directive_only = shift;
 
-  # For debugging purposes, see below
-  my $directive_file_contents = '';
-  my @lines = ();
 
-  open DIRECTIVE_FILE, '<', $directive_file
-    or ftp_abort("FATAL: open($directive_file) failed: $!");
-  $directive_file_contents = join('', (@lines = <DIRECTIVE_FILE>));
-  seek DIRECTIVE_FILE, 0, 0
-    or ftp_abort("FATAL: seek($directive_file) failed: $!");
-  my $directive = read_directive(*DIRECTIVE_FILE{IO});
-  close DIRECTIVE_FILE
-    or ftp_warn("close($directive_file) failed: $!");
 
-  # If we don't know whose project this file belongs to, because the
-  # 'directory:' line is messed up or not there, we'd still like to let the
-  # uploader know something went wrong.  So let's see if we can match the
-  # directive file signature against one of our public keyrings.
-  my @tmp_keyrings;
-  open(TMP,"/usr/bin/find $package_config_base -name pubring.gpg|");
-  while(<TMP>) {
-    chomp();
-    push(@tmp_keyrings,$_);
-  }
-  close(TMP);
 
-  my $tmp_retval = verify_keyring($directive_file,$directive_file_contents,
-                                 @tmp_keyrings);
-  push(@{$info{email}},$1)
-    if ($tmp_retval =~ /Good signature from .*?<(.*?)>/);
 
-  my $cnt = 0; # Keep track of the order of directives...
-  my $signed = 0;
-  # If there is a command in the directive that doesn't require an actual
-  # file to work on, we won't require the filename line in the directive
-  # file. This will allow people to upload a directive file only to
-  # archive/create symlinks/remove symlinks
-  my $filename_required = 1;
+# As temporary scaffolding, also sets the %info quasi-global.
+sub interpret_directive {
+  my $directive = shift;               # presumed tainted
+  my $directive_file_contents = shift; # temporary scaffold
+
+  my %header = ( package => undef, directory => undef, version => undef );
+  my @ops;
+  my $have_install = 0;        # can only install one file per directive
+  my $filename;
+  my $cnt = 0; # TODO: remove this
 
   foreach my $item (@$directive) {
     my $tainted_cmd = lc $item->[0];
@@ -1316,6 +1289,8 @@ sub read_directive_file {
 
     if ($tainted_cmd eq 'directory') {
       parse_directory_line($tainted_val, $directive_file_contents,0);
+      $header{directory} = $info{directory};
+      $header{package} = $info{package};
     } elsif ($tainted_cmd eq 'filename') {
       # We use the same filename restrictions as scan_incoming
       $tainted_val =~ /^($RE_filename_here)$/
@@ -1327,6 +1302,7 @@ sub read_directive_file {
            ."Error at filename directive: $val.",1,$directive_file_contents)
        if exists $info{"filename"};
 
+      $filename = $val;
       $info{"filename"} = {"value" => $val, "order" => $cnt++};  # ok.
     } elsif ($tainted_cmd eq 'version') {
       $tainted_val =~ /^(\d+\.\d+)$/
@@ -1342,28 +1318,33 @@ sub read_directive_file {
            1,$directive_file_contents)
        if exists $info{"version"};
 
+      $header{version} = $val;  # TODO:  parse?
       $info{"version"} = $val; #ok.
     } elsif ($tainted_cmd eq 'symlink') {
       $tainted_val =~ /^($RE_filename_relative)\s+($RE_filename_relative)$/
        or fatal("invalid parameters for symlink command: $tainted_val",
                 1,$directive_file_contents);
       # $1 -- link target      $2 -- link name
+      push @ops, [symlink => $1, $2];
       $info{"symlink-$1"} = {"link" => $2, "order" => $cnt++}; #ok.
     } elsif ($tainted_cmd eq 'rmsymlink') {
       $tainted_val =~ /^($RE_filename_relative)$/
        or fatal("invalid parameters for rmsymlink command: $tainted_val",
                 1,$directive_file_contents);
+      push @ops, [rmsymlink => $1];
       $info{"rmsymlink-$1"} = {"order" => $cnt++}; #ok.
     } elsif ($tainted_cmd eq 'archive') {
       $tainted_val =~ /^($RE_filename_relative)$/
        or fatal("invalid parameters for archive command: $tainted_val",
                 1,$directive_file_contents);
+      push @ops, [archive => $1];
       $info{"archive-$1"} = {"order" => $cnt++}; #ok.
     } elsif ($tainted_cmd eq 'replace') {
       # This command is only supported from v1.2
       $tainted_val =~ /^(true|false)$/
        or fatal("invalid parameters for replace command: $tainted_val",
                 1,$directive_file_contents);
+      push @ops, [set => replace => ($1 eq 'true')];
       $info{"replace"} = $1; #ok.
     } elsif ($tainted_cmd eq 'comment') {
       # Comments are ok, we ignore them
@@ -1374,7 +1355,51 @@ sub read_directive_file {
       fatal("Invalid directive line:\n\n  $tainted_cmd $tainted_val",
            1,$directive_file_contents);
     }
+
+    if (!$have_install && $filename && defined $header{directory})
+      { push @ops, [install => $filename]; $have_install = 1 }
+  }
+
+  unshift @ops, [header => \%header];
+
+  return \@ops;
+}
+
+sub read_directive_file {
+  my $directive_file = shift;
+  my $uploaded_file = shift;
+  my $directive_only = shift;
+
+  # For debugging purposes, see below
+  my $directive_file_contents = '';
+
+  open DIRECTIVE_FILE, '<', $directive_file
+    or ftp_abort("FATAL: open($directive_file) failed: $!");
+  $directive_file_contents = join('', <DIRECTIVE_FILE>);
+  seek DIRECTIVE_FILE, 0, 0
+    or ftp_abort("FATAL: seek($directive_file) failed: $!");
+  my $directive = read_directive(*DIRECTIVE_FILE{IO});
+  close DIRECTIVE_FILE
+    or ftp_warn("close($directive_file) failed: $!");
+
+  # If we don't know whose project this file belongs to, because the
+  # 'directory:' line is messed up or not there, we'd still like to let the
+  # uploader know something went wrong.  So let's see if we can match the
+  # directive file signature against one of our public keyrings.
+  my @tmp_keyrings;
+  open(TMP,"/usr/bin/find $package_config_base -name pubring.gpg|");
+  while(<TMP>) {
+    chomp();
+    push(@tmp_keyrings,$_);
   }
+  close(TMP);
+
+  my $tmp_retval = verify_keyring($directive_file,$directive_file_contents,
+                                 @tmp_keyrings);
+  push(@{$info{email}},$1)
+    if ($tmp_retval =~ /Good signature from .*?<(.*?)>/);
+
+  my @ops = interpret_directive($directive, $directive_file_contents);
 
   if (exists($info{"replace"}) && ($info{"version"} eq '1.1')) {
     fatal("invalid directive 'replace', not supported prior to version 1.2",
@@ -1398,6 +1423,12 @@ sub read_directive_file {
     fatal("no directory directive specified in $directive_file",1);
   }
 
+  # If there is a command in the directive that doesn't require an actual
+  # file to work on, we won't require the filename line in the directive
+  # file. This will allow people to upload a directive file only to
+  # archive/create symlinks/remove symlinks
+  my $filename_required = 1;
+
   # There are a few possibilities regarding the 'filename' directive
   # 1. It exists in the directive file - there is no problem
   # 2. It doesn't exist in the directive file