Add structured exception for directive syntax errors

This also improves the reporting of these errors, with a highlight line
inserted for each error encountered, in context.

diff --git a/gatekeeper.pl b/gatekeeper.pl
index ec23cefc9d5833fcfa4e4ef67527fd86714c238e..d4d3f46e2b95ef0b27816377dcd1e85d4b01339e 100755 (executable)
--- a/gatekeeper.pl
+++ b/gatekeeper.pl
@@ -548,6 +548,16 @@ BEGIN {
   }
 }
 
+{
+  package Local::Exception::directive_syntax;
+  {our @ISA = qw(Local::Exception)}
+
+  sub trace    { (shift)->{trace}      }
+
+  sub trace_msg
+    { return join("\n", map join(': ', @$_), @{(shift)->{trace}})."\n" }
+}
+
 =item throw $type => ($key => $value)...
 
 Throw a TYPE exception, with further options specified as key/value pairs.
@@ -1675,6 +1685,8 @@ sub interpret_directive {
   my $directive_file_contents = shift; # temporary scaffold
 
   my @errors;
+  my @trace;
+  my $version_error;
 
   my %options = ( replace => undef );
   my %header = ( version => undef, options => \%options,
@@ -1692,31 +1704,39 @@ sub interpret_directive {
       if ($versions[0][1] =~ /^(\d+\.\d+)$/) {
        my $val = $1;           # so far so good
 
-       # We only support version 1.1/1.2 right now!
-       push @errors, "invalid version $val, not supported"
-         if (($val ne '1.1') and ($val ne '1.2'));
-
        $header{version} = $val; # TODO:  parse?
       } else {
        # version value does not match required pattern
        push @errors, "invalid version $versions[0][1]";
+       $version_error = 'invalid version';
       }
     } elsif (scalar @versions > 1) {
       push @errors, "invalid multiple version elements";
+      $version_error = 'multiple version elements';
     } else {   # no version at all; no longer allowed
       push @errors, "no version specified in directive";
     }
   }
 
+  if ($header{version}
+      && $header{version} ne '1.1' && $header{version} ne '1.2') {
+    push @errors, "invalid version $header{version}, not supported";
+    $version_error = 'unsupported version';
+  }
+
   foreach my $item (@$directive) {
     my $tainted_cmd = lc $item->[0];
     my $tainted_val = $item->[1];
 
+    push @trace, $item;
+
     if (!$tainted_val && !($tainted_cmd =~ m/^comment|^no-op/)) {
       push @errors, "invalid $tainted_cmd element with no value";
+      push @trace, ['  ^--', 'element with no value'];
     } elsif ($tainted_cmd eq 'directory') {
       unless ($tainted_val =~ m/^($RE_filename_relative)$/) {
        push @errors, "invalid directory $tainted_val";
+       push @trace, ['  ^--', 'this directory name is invalid'];
        next;
       }
       my $val = $1;  # so far so good
@@ -1727,6 +1747,7 @@ sub interpret_directive {
       # A couple of subdir levels are ok, but don't allow hundreds.
       if ($dir_depth > MAX_DIRECTORY_DEPTH) {
        push @errors, "$dir_depth levels is too deep, in $val";
+       push @trace, ['  ^--', 'this directory name is nested too deeply'];
        next;
       }
 
@@ -1735,6 +1756,7 @@ sub interpret_directive {
        push @errors,
          "Only one directory directive is allowed per directive file. "
            ."Error at directory directive: $val";
+       push @trace, ['  ^--', 'second directory element found here'];
        next;
       }
 
@@ -1745,6 +1767,7 @@ sub interpret_directive {
       # We use the same filename restrictions as scan_incoming
       unless ($tainted_val =~ /^($RE_filename_here)$/) {
        push @errors, "invalid filename $tainted_val";
+       push @trace, ['  ^--', 'this filename is invalid'];
        next;
       }
       my $val = $1;  # so far so good
@@ -1754,16 +1777,20 @@ sub interpret_directive {
        push @errors,
          "Only one filename directive is allowed per directive file.  "
            ."Error at filename directive: $val.";
+       push @trace, ['  ^--', 'second filename element found here'];
        next;
       }
 
       $header{filename} = $val;
     } elsif ($tainted_cmd eq 'version') {
-      # already handled above
+      # already handled above; insert any error into the trace
+      push @trace, ['  ^--', $version_error] if $version_error;
     } elsif ($tainted_cmd eq 'symlink') {
       unless ($tainted_val =~
              /^($RE_filename_relative)\s+($RE_filename_relative)$/) {
        push @errors, "invalid parameters for symlink command: $tainted_val";
+       push @trace,
+         ['  ^--', 'invalid parameters here; need TARGET and LINKNAME'];
        next;
       }
       # $1 -- link target      $2 -- link name
@@ -1771,6 +1798,8 @@ sub interpret_directive {
     } elsif ($tainted_cmd eq 'rmsymlink') {
       unless ($tainted_val =~ /^($RE_filename_relative)$/) {
        push @errors, "invalid parameters for rmsymlink command: $tainted_val";
+       push @trace,
+         ['  ^--', 'invalid parameter here; need relative filename'];
        next;
       }
       push @ops, [rmsymlink => $1];
@@ -1778,6 +1807,8 @@ sub interpret_directive {
       unless ($tainted_val =~ /^($RE_filename_relative)$/) {
        push @errors,
          "invalid parameters for archive command: $tainted_val";
+       push @trace,
+         ['  ^--', 'invalid parameter here; need relative filename'];
        next;
       }
       push @ops, [archive => $1];
@@ -1786,12 +1817,15 @@ sub interpret_directive {
       unless ($tainted_val =~ /^(true|false)$/) {
        push @errors,
          "invalid parameters for replace command: $tainted_val";
+       push @trace,
+         ['  ^--', 'invalid parameter here; need "true" or "false"'];
        next;
       }
 
       if ($header{version} eq '1.1') {
        push @errors,
          "invalid directive 'replace', not supported prior to version 1.2";
+       push @trace, ['  ^--', 'this element was introduced in version 1.2'];
        next;
       }
 
@@ -1803,6 +1837,7 @@ sub interpret_directive {
       push @ops, ['no-op'];
     } else {
       push @errors, "Invalid directive line:\n\n  $tainted_cmd $tainted_val";
+      push @trace, ['  ^--', 'this element is not recognized'];
     }
 
     if (!defined($install)
@@ -1821,9 +1856,9 @@ sub interpret_directive {
   }
 
   if (@errors) {
-    # TODO:  eventually report all errors found
-    # for now, just report the first error, to emulate an immediate fatal()
-    fatal($errors[0],1,$directive_file_contents);
+    ftp_syslog('err', $errors[0]);
+    throw directive_syntax =>
+      trace => \@trace, summary => $errors[0];
   }
 
   return \@ops;
@@ -2529,8 +2564,10 @@ foreach my $packet (@packets) {  # each list element is an array reference
       }
 
       # If a send_to_user key is set, then this came from a call to fatal().
-      if (defined $E->{send_to_user}) {
+      if (defined $E->{send_to_user}) {                # scaffolding for now
        mail($E->{message},$E->{send_to_user});
+      } elsif ($E->type_p('directive_syntax')) {
+       mail(join("\n",$E->{summary},'',$E->trace_msg),1);
       }
     } else {
       # Exceptions thrown by perl itself come out as strings