ParseXS improvements

MANIFEST

@@ -3703,13 +3703,15 @@ dist/ExtUtils-ParseXS/t/lib/PrimitiveCapture.pm			Primitive STDOUT/ERR capturing
 dist/ExtUtils-ParseXS/t/lib/TypemapTest/Foo.pm			ExtUtils::Typemaps tests
 dist/ExtUtils-ParseXS/t/pseudotypemap1				A test-typemap
 dist/ExtUtils-ParseXS/t/typemap					Standard typemap for controlled testing
+dist/ExtUtils-ParseXS/t/XSAlias.xs				Test file for ExtUtils::ParseXS ALIAS tests
 dist/ExtUtils-ParseXS/t/XSBroken.xs				Test file for ExtUtils::ParseXS tests
 dist/ExtUtils-ParseXS/t/XSFalsePositive.xs			Test file for ExtUtils::ParseXS tests
 dist/ExtUtils-ParseXS/t/XSFalsePositive2.xs			Test file for ExtUtils::ParseXS tests
 dist/ExtUtils-ParseXS/t/XSInclude.xsh				Test file for ExtUtils::ParseXS tests
 dist/ExtUtils-ParseXS/t/XSMore.xs				Test file for ExtUtils::ParseXS tests
 dist/ExtUtils-ParseXS/t/XSTest.pm				Test file for ExtUtils::ParseXS tests
 dist/ExtUtils-ParseXS/t/XSTest.xs				Test file for ExtUtils::ParseXS tests
+dist/ExtUtils-ParseXS/t/XSTightDirectives.xs			Test file for ExtUtils::ParseXS tests
 dist/ExtUtils-ParseXS/t/XSUsage.pm				ExtUtils::ParseXS tests
 dist/ExtUtils-ParseXS/t/XSUsage.xs				ExtUtils::ParseXS tests
 dist/ExtUtils-ParseXS/t/XSWarn.xs				ExtUtils::ParseXS tests

dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm

@@ -11,7 +11,7 @@ use Symbol;
 
 our $VERSION;
 BEGIN {
-  $VERSION = '3.47';
+  $VERSION = '3.48';
   require ExtUtils::ParseXS::Constants; ExtUtils::ParseXS::Constants->VERSION($VERSION);
   require ExtUtils::ParseXS::CountLines; ExtUtils::ParseXS::CountLines->VERSION($VERSION);
   require ExtUtils::ParseXS::Utilities; ExtUtils::ParseXS::Utilities->VERSION($VERSION);
@@ -31,6 +31,7 @@ use ExtUtils::ParseXS::Utilities qw(
   analyze_preprocessor_statements
   set_cond
   Warn
+  WarnHint
   current_line_number
   blurt
   death
@@ -47,7 +48,7 @@ our @EXPORT_OK = qw(
 
 ##############################
 # A number of "constants"
-
+our $DIE_ON_ERROR;
 our ($C_group_rex, $C_arg);
 # Group in C (no support for comments or literals)
 $C_group_rex = qr/ [({\[]
@@ -103,6 +104,7 @@ sub process_file {
     typemap         => [],
     versioncheck    => 1,
     FH              => Symbol::gensym(),
+    die_on_error    => $DIE_ON_ERROR, # if true we die() and not exit() after errors
     %options,
   );
   $args{except} = $args{except} ? ' TRY' : '';
@@ -133,6 +135,8 @@ sub process_file {
   $self->{WantLineNumbers} = $args{linenumbers};
   $self->{IncludedFiles} = {};
 
+  $self->{die_on_error} = $args{die_on_error};
+
   die "Missing required parameter 'filename'" unless $args{filename};
   $self->{filepathname} = $args{filename};
   ($self->{dir}, $self->{filename}) =
@@ -873,15 +877,15 @@ EOF
        "        (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
     }
 
-    for my $operator (keys %{ $self->{OverloadsThisXSUB} }) {
+    for my $operator (sort keys %{ $self->{OverloadsThisXSUB} }) {
       $self->{Overloaded}->{$self->{Package}} = $self->{Packid};
       my $overload = "$self->{Package}\::($operator";
       push(@{ $self->{InitFileCode} },
         "        (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
     }
   } # END 'PARAGRAPH' 'while' loop
 
-  for my $package (keys %{ $self->{Overloaded} }) { # make them findable with fetchmethod
+  for my $package (sort keys %{ $self->{Overloaded} }) { # make them findable with fetchmethod
     my $packid = $self->{Overloaded}->{$package};
     print Q(<<"EOF");
 #XS_EUPXS(XS_${packid}_nil); /* prototype to pass -Wmissing-prototypes */
@@ -968,15 +972,15 @@ EOF
 #
 EOF
 
-  if (%{ $self->{Overloaded} }) {
+  if (keys %{ $self->{Overloaded} }) {
     # once if any overloads
     print Q(<<"EOF");
 #    /* register the overloading (type 'A') magic */
 ##if PERL_VERSION_LE(5, 8, 999) /* PERL_VERSION_LT is 5.33+ */
 #    PL_amagic_generation++;
 ##endif
 EOF
-    for my $package (keys %{ $self->{Overloaded} }) {
+    for my $package (sort keys %{ $self->{Overloaded} }) {
       # once for each package with overloads
       my $fallback = $self->{Fallback}->{$package} || "&PL_sv_undef";
       print Q(<<"EOF");
@@ -1310,26 +1314,86 @@ sub get_aliases {
   my ($line) = @_;
   my ($orig) = $line;
 
+  # we use this later for symbolic aliases
+  my $fname = $self->{Packprefix} . $self->{func_name};
+
   # Parse alias definitions
   # format is
-  #    alias = value alias = value ...
-
-  while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
-    my ($alias, $value) = ($1, $2);
+  #    alias = value Pack::alias = value ...
+  # or
+  #    alias => other
+  # or
+  #    alias => Pack::other
+  # or
+  #    Pack::alias => Other::alias
+
+  while ($line =~ s/^\s*([\w:]+)\s*=(>?)\s*([\w:]+)\s*//) {
+    my ($alias, $is_symbolic, $value) = ($1, $2, $3);
     my $orig_alias = $alias;
 
+    blurt( $self, "Error: In alias definition for '$alias' the value may not"
+                  . " contain ':' unless it is symbolic.")
+        if !$is_symbolic and $value=~/:/;
+
     # check for optional package definition in the alias
     $alias = $self->{Packprefix} . $alias if $alias !~ /::/;
 
+    if ($is_symbolic) {
+      my $orig_value = $value;
+      $value = $self->{Packprefix} . $value if $value !~ /::/;
+      if (defined $self->{XsubAliases}->{$value}) {
+        $value = $self->{XsubAliases}->{$value};
+      } elsif ($value eq $fname) {
+        $value = 0;
+      } else {
+        blurt( $self, "Error: Unknown alias '$value' in symbolic definition for '$orig_alias'");
+      }
+    }
+
     # check for duplicate alias name & duplicate value
-    Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'")
-      if defined $self->{XsubAliases}->{$alias};
+    my $prev_value = $self->{XsubAliases}->{$alias};
+    if (defined $prev_value) {
+      if ($prev_value eq $value) {
+        Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'")
+      } else {
+        Warn( $self, "Warning: Conflicting duplicate alias '$orig_alias'"
+                     . " changes definition from '$prev_value' to '$value'");
+        delete $self->{XsubAliasValues}->{$prev_value}{$alias};
+      }
+    }
 
-    Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values")
-      if $self->{XsubAliasValues}->{$value};
+    # Check and see if this alias results in two aliases having the same
+    # value, we only check non-symbolic definitions as the whole point of
+    # symbolic definitions is to say we want to duplicate the value and
+    # it is NOT a mistake.
+    unless ($is_symbolic) {
+      my @keys= sort keys %{$self->{XsubAliasValues}->{$value}||{}};
+      # deal with an alias of 0, which might not be in the XsubAlias dataset
+      # yet as 0 is the default for the base function ($fname)
+      push @keys, $fname
+        if $value eq "0" and !defined $self->{XsubAlias}{$fname};
+      if (@keys) {
+        @keys= map { "'$_'" }
+               map { my $copy= $_;
+                     $copy=~s/^$self->{Packprefix}//;
+                     $copy
+                   } @keys;
+        WarnHint( $self,
+                  "Warning: Aliases '$orig_alias' and "
+                  . join(", ", @keys)
+                  . " have identical values of $value"
+                  . ( $value eq "0"
+                      ? " - the base function"
+                      : "" ),
+                  !$self->{XsubAliasValueClashHinted}++
+                  ? "If this is deliberate use a symbolic alias instead."
+                  : undef
+        );
+      }
+    }
 
     $self->{XsubAliases}->{$alias} = $value;
-    $self->{XsubAliasValues}->{$value} = $orig_alias;
+    $self->{XsubAliasValues}->{$value}{$alias}++;
   }
 
   blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'")
@@ -1800,11 +1864,17 @@ sub fetch_para {
     $self->_process_module_xs_line($1, $2, $3);
   }
 
+  # count how many #ifdef levels we see in this paragraph
+  # decrementing when we see an endif. if we see an elsif
+  # or endif without a corresponding #ifdef then we dont
+  # consider it part of this paragraph.
+  my $if_level = 0;
   for (;;) {
     $self->_maybe_skip_pod;
 
     $self->_maybe_parse_typemap_block;
 
+    my $final;
     if ($self->{lastline} !~ /^\s*#/ # not a CPP directive
         # CPP directives:
         #    ANSI:    if ifdef ifndef elif else endif define undef
@@ -1814,7 +1884,7 @@ sub fetch_para {
         #   others:    ident (gcc notes that some cpps have this one)
         || $self->{lastline} =~ /^\#[ \t]*
                                   (?:
-                                        (?:if|ifn?def|elif|else|endif|
+                                        (?:if|ifn?def|elif|else|endif|elifn?def|
                                            define|undef|pragma|error|
                                            warning|line\s+\d+|ident)
                                         \b
@@ -1825,6 +1895,31 @@ sub fetch_para {
     )
     {
       last if $self->{lastline} =~ /^\S/ && @{ $self->{line} } && $self->{line}->[-1] eq "";
+      if ($self->{lastline}=~/^#[ \t]*(if|ifn?def|elif|else|endif|elifn?def)\b/) {
+        my $type = $1; # highest defined capture buffer, "if" for any if like condition
+        if ($type =~ /^if/) {
+          if (@{$self->{line}}) {
+            # increment level
+            $if_level++;
+          } else {
+            $final = 1;
+          }
+        } elsif ($type eq "endif") {
+          if ($if_level) { # are we in an if that was started in this paragraph?
+            $if_level--;   # yep- so decrement to end this if block
+          } else {
+            $final = 1;
+          }
+        } elsif (!$if_level) {
+          # not in an #ifdef from this paragraph, thus
+          # this directive should not be part of this paragraph.
+          $final = 1;
+        }
+      }
+      if ($final and @{$self->{line}}) {
+        return 1;
+      }
+
       push(@{ $self->{line} }, $self->{lastline});
       push(@{ $self->{line_no} }, $self->{lastline_no});
     }
@@ -1838,6 +1933,9 @@ sub fetch_para {
 
     chomp $self->{lastline};
     $self->{lastline} =~ s/^\s+$//;
+    if ($final) {
+      last;
+    }
   }
 
   # Nuke trailing "line" entries until there's one that's not empty

dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pod

@@ -19,6 +19,7 @@ ExtUtils::ParseXS - converts Perl XS code into C code
                       linenumbers => 1,
                       optimize => 1,
                       prototypes => 1,
+                      die_on_error => 0,
                     );
 
   # Legacy non-OO interface using a singleton:
@@ -119,6 +120,15 @@ Default is true.
 
 I<Maintainer note:> I have no clue what this does.  Strips function prefixes?
 
+=item B<die_on_error>
+
+Normally ExtUtils::ParseXS will terminate the program with an C<exit(1)> after
+printing the details of the exception to STDERR via (warn). This can be awkward
+when it is used programmatically and not via xsubpp, so this option can be used
+to cause it to die instead by providing a true value. When not provided this
+defaults to the value of C<$ExtUtils::ParseXS::DIE_ON_ERROR> which in turn
+defaults to false.
+
 =back
 
 =item $pxs->report_error_count()

dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm

@@ -3,7 +3,7 @@ use strict;
 use warnings;
 use Symbol;
 
-our $VERSION = '3.47';
+our $VERSION = '3.48';
 
 =head1 NAME
 

dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm

@@ -1,7 +1,7 @@
 package ExtUtils::ParseXS::CountLines;
 use strict;
 
-our $VERSION = '3.47';
+our $VERSION = '3.48';
 
 our $SECTION_END_MARKER;
 

dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm

@@ -2,7 +2,7 @@ package ExtUtils::ParseXS::Eval;
 use strict;
 use warnings;
 
-our $VERSION = '3.47';
+our $VERSION = '3.48';
 
 =head1 NAME