ParseXS - better support for duplicate ALIASes

Sometimes you *want* to create multiple names for the same
functionality, but doing so with the ALIAS functionality requires
awkward workarounds. This adds a new "symbolic alias" that does
not warn on dupes as creating a dupe is its whole point. For a
symbolic alias the value is the name of an existing alias.

This also cleans up some of the warnings related to aliases so
we distinguish between when a duplicate is truly ignored or
where it overrides a previous value. And deal with a few other
edge cases properly.

MANIFEST

@@ -3703,6 +3703,7 @@ 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/lib/ExtUtils/ParseXS.pm

@@ -31,6 +31,7 @@ use ExtUtils::ParseXS::Utilities qw(
   analyze_preprocessor_statements
   set_cond
   Warn
+  WarnHint
   current_line_number
   blurt
   death
@@ -1312,24 +1313,71 @@ sub get_aliases {
 
   # 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}) {
+        blurt( $self, "Error: Unknown alias '$value' in symbolic definition for '$orig_alias'");
+      }
+      $value = $self->{XsubAliases}->{$value};
+    }
+
     # 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}||{}};
+      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",
+                  !$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'")

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

@@ -21,6 +21,7 @@ our (@ISA, @EXPORT_OK);
   analyze_preprocessor_statements
   set_cond
   Warn
+  WarnHint
   current_line_number
   blurt
   death
@@ -654,18 +655,56 @@ sub current_line_number {
 
 =item * Purpose
 
+Print warnings with line number details at the end.
+
 =item * Arguments
 
+List of text to output.
+
 =item * Return Value
 
+None.
+
 =back
 
 =cut
 
 sub Warn {
+  my ($self)=shift;
+  $self->WarnHint(@_,undef);
+}
+
+=head2 C<WarnHint()>
+
+=over 4
+
+=item * Purpose
+
+Prints warning with line number details. The last argument is assumed
+to be a hint string.
+
+=item * Arguments
+
+List of strings to warn, followed by one argument representing a hint.
+If that argument is defined then it will be split on newlines and output
+line by line after the main warning.
+
+=item * Return Value
+
+None.
+
+=back
+
+=cut
+
+sub WarnHint {
   my $self = shift;
+  my $hint = pop;
   my $warn_line_number = $self->current_line_number();
-  print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
+  print STDERR join("",@_), " in $self->{filename}, line $warn_line_number\n";
+  if ($hint) {
+    print STDERR "    ($_)\n" for split /\n/, $hint;
+  }
 }
 
 =head2 C<blurt()>

dist/ExtUtils-ParseXS/lib/perlxs.pod

@@ -1332,6 +1332,46 @@ C<BAR::getit()> for this function.
         OUTPUT:
           timep
 
+A warning will be produced when you create more than one alias to the same
+value. This may be worked around in a backwards compatible way by creating
+multiple defines which resolve to the same value, or with a modern version
+of ExtUtils::ParseXS you can use a symbolic alias, which are denoted with
+a C<< => >> instead of a C<< = >>. For instance you could change the above
+so that the alias section looked like this:
+
+	ALIAS:
+	    FOO::gettime = 1
+	    BAR::getit = 2
+            BAZ::gettime => FOO::gettime
+
+this would have the same effect as this:
+
+	ALIAS:
+	    FOO::gettime = 1
+	    BAR::getit = 2
+            BAZ::gettime = 1
+
+except that the latter will produce warnings during the build process. A
+mechanism that would work in a backwards compatible way with older
+versions of our tool chain would be to do this:
+
+    #define FOO_GETTIME 1
+    #define BAR_GETIT 2
+    #define BAZ_GETTIME 1
+
+    bool_t
+    rpcb_gettime(host,timep)
+          char *host
+          time_t &timep
+	ALIAS:
+	    FOO::gettime = FOO_GETTIME
+	    BAR::getit = BAR_GETIT
+            BAZ::gettime = BAZ_GETTIME
+	INIT:
+	  printf("# ix = %d\n", ix );
+        OUTPUT:
+          timep
+
 =head2 The OVERLOAD: Keyword
 
 Instead of writing an overloaded interface using pure Perl, you

dist/ExtUtils-ParseXS/t/001-basic.t

@@ -1,7 +1,7 @@
 #!/usr/bin/perl
 
 use strict;
-use Test::More tests => 22;
+use Test::More tests => 24;
 use Config;
 use DynaLoader;
 use ExtUtils::CBuilder;
@@ -238,6 +238,48 @@ like $stderr, '/No INPUT definition/', "Exercise typemap error";
   is $count, 2, "Saw XS_MY_do definition the expected number of times";
 }
 
+{ # Alias check
+  my $pxs = ExtUtils::ParseXS->new;
+  tie *FH, 'Foo';
+  my $stderr = PrimitiveCapture::capture_stderr(sub {
+    $pxs->process_file(
+      filename => 'XSAlias.xs',
+      output => \*FH,
+      prototypes => 1);
+  });
+  my $content = tied(*FH)->{buf};
+  my $count = 0;
+  $count++ while $content=~/^XS_EUPXS\(XS_My_do\)\n\{/mg;
+  is $stderr,
+    "Warning: Aliases 'pox' and 'dox', 'lox' have"
+    . " identical values in XSAlias.xs, line 9\n"
+    . "    (If this is deliberate use a symbolic alias instead.)\n"
+    . "Warning: Conflicting duplicate alias 'pox' changes"
+    . " definition from '1' to '2' in XSAlias.xs, line 10\n"
+    . "Warning: Aliases 'docks' and 'dox', 'lox' have"
+    . " identical values in XSAlias.xs, line 11\n",
+    "Saw expected warnings from XSAlias.xs";
+
+  my $expect = quotemeta(<<'EOF_CONTENT');
+         cv = newXSproto_portable("My::dachs", XS_My_do, file, "$");
+         XSANY.any_i32 = 1;
+         cv = newXSproto_portable("My::do", XS_My_do, file, "$");
+         XSANY.any_i32 = 0;
+         cv = newXSproto_portable("My::docks", XS_My_do, file, "$");
+         XSANY.any_i32 = 1;
+         cv = newXSproto_portable("My::dox", XS_My_do, file, "$");
+         XSANY.any_i32 = 1;
+         cv = newXSproto_portable("My::lox", XS_My_do, file, "$");
+         XSANY.any_i32 = 1;
+         cv = newXSproto_portable("My::pox", XS_My_do, file, "$");
+         XSANY.any_i32 = 2;
+EOF_CONTENT
+  $expect=~s/(?:\\[ ])+/\\s+/g;
+  $expect=qr/$expect/;
+  like $content, $expect, "Saw expected alias initialization";
+
+  #diag $content;
+}
 #####################################################################
 
 sub Foo::TIEHANDLE { bless {}, 'Foo' }

dist/ExtUtils-ParseXS/t/XSAlias.xs

@@ -0,0 +1,17 @@
+MODULE = My PACKAGE = My
+
+void
+do(dbh)
+   SV *dbh
+ALIAS:
+    dox = 1
+    lox => dox
+    pox = 1
+    pox = 2
+    docks = 1
+    dachs => lox
+CODE:
+{
+   int x;
+   ++x;
+}