Skip to content

Commit 3478106

Browse files
demerphqdemerphq
committed
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.
1 parent b263689 commit 3478106

File tree

6 files changed

+198
-11
lines changed

6 files changed

+198
-11
lines changed

‎MANIFEST

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3703,6 +3703,7 @@ dist/ExtUtils-ParseXS/t/lib/PrimitiveCapture.pm Primitive STDOUT/ERR capturing
37033703
dist/ExtUtils-ParseXS/t/lib/TypemapTest/Foo.pm ExtUtils::Typemaps tests
37043704
dist/ExtUtils-ParseXS/t/pseudotypemap1 A test-typemap
37053705
dist/ExtUtils-ParseXS/t/typemap Standard typemap for controlled testing
3706+
dist/ExtUtils-ParseXS/t/XSAlias.xs Test file for ExtUtils::ParseXS ALIAS tests
37063707
dist/ExtUtils-ParseXS/t/XSBroken.xs Test file for ExtUtils::ParseXS tests
37073708
dist/ExtUtils-ParseXS/t/XSFalsePositive.xs Test file for ExtUtils::ParseXS tests
37083709
dist/ExtUtils-ParseXS/t/XSFalsePositive2.xs Test file for ExtUtils::ParseXS tests

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

Lines changed: 57 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ use ExtUtils::ParseXS::Utilities qw(
3131
analyze_preprocessor_statements
3232
set_cond
3333
Warn
34+
WarnHint
3435
current_line_number
3536
blurt
3637
death
@@ -1312,24 +1313,71 @@ sub get_aliases {
13121313

13131314
# Parse alias definitions
13141315
# format is
1315-
# alias = value alias = value ...
1316-
1317-
while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1318-
my ($alias, $value) = ($1, $2);
1316+
# alias = value Pack::alias = value ...
1317+
# or
1318+
# alias => other
1319+
# or
1320+
# alias => Pack::other
1321+
# or
1322+
# Pack::alias => Other::alias
1323+
1324+
while ($line =~ s/^\s*([\w:]+)\s*=(>?)\s*([\w:]+)\s*//) {
1325+
my ($alias, $is_symbolic, $value) = ($1, $2, $3);
13191326
my $orig_alias = $alias;
13201327

1328+
blurt( $self, "Error: In alias definition for '$alias' the value may not"
1329+
. " contain ':' unless it is symbolic.")
1330+
if !$is_symbolic and $value=~/:/;
1331+
13211332
# check for optional package definition in the alias
13221333
$alias = $self->{Packprefix} . $alias if $alias !~ /::/;
13231334

1335+
if ($is_symbolic) {
1336+
my $orig_value = $value;
1337+
$value = $self->{Packprefix} . $value if $value !~ /::/;
1338+
if (!defined $self->{XsubAliases}->{$value}) {
1339+
blurt( $self, "Error: Unknown alias '$value' in symbolic definition for '$orig_alias'");
1340+
}
1341+
$value = $self->{XsubAliases}->{$value};
1342+
}
1343+
13241344
# check for duplicate alias name & duplicate value
1325-
Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'")
1326-
if defined $self->{XsubAliases}->{$alias};
1345+
my $prev_value = $self->{XsubAliases}->{$alias};
1346+
if (defined $prev_value) {
1347+
if ($prev_value eq $value) {
1348+
Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'")
1349+
} else {
1350+
Warn( $self, "Warning: Conflicting duplicate alias '$orig_alias'"
1351+
. " changes definition from '$prev_value' to '$value'");
1352+
delete $self->{XsubAliasValues}->{$prev_value}{$alias};
1353+
}
1354+
}
13271355

1328-
Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values")
1329-
if $self->{XsubAliasValues}->{$value};
1356+
# Check and see if this alias results in two aliases having the same
1357+
# value, we only check non-symbolic definitions as the whole point of
1358+
# symbolic definitions is to say we want to duplicate the value and
1359+
# it is NOT a mistake.
1360+
unless ($is_symbolic) {
1361+
my @keys= sort keys %{$self->{XsubAliasValues}->{$value}||{}};
1362+
if (@keys) {
1363+
@keys= map { "'$_'" }
1364+
map { my $copy= $_;
1365+
$copy=~s/^$self->{Packprefix}//;
1366+
$copy
1367+
} @keys;
1368+
WarnHint( $self,
1369+
"Warning: Aliases '$orig_alias' and "
1370+
. join(", ", @keys)
1371+
. " have identical values",
1372+
!$self->{XsubAliasValueClashHinted}++
1373+
? "If this is deliberate use a symbolic alias instead."
1374+
: undef
1375+
);
1376+
}
1377+
}
13301378

13311379
$self->{XsubAliases}->{$alias} = $value;
1332-
$self->{XsubAliasValues}->{$value} = $orig_alias;
1380+
$self->{XsubAliasValues}->{$value}{$alias}++;
13331381
}
13341382

13351383
blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'")

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

Lines changed: 40 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ our (@ISA, @EXPORT_OK);
2121
analyze_preprocessor_statements
2222
set_cond
2323
Warn
24+
WarnHint
2425
current_line_number
2526
blurt
2627
death
@@ -654,18 +655,56 @@ sub current_line_number {
654655
655656
=item * Purpose
656657
658+
Print warnings with line number details at the end.
659+
657660
=item * Arguments
658661
662+
List of text to output.
663+
659664
=item * Return Value
660665
666+
None.
667+
661668
=back
662669
663670
=cut
664671

665672
sub Warn {
673+
my ($self)=shift;
674+
$self->WarnHint(@_,undef);
675+
}
676+
677+
=head2 C<WarnHint()>
678+
679+
=over 4
680+
681+
=item * Purpose
682+
683+
Prints warning with line number details. The last argument is assumed
684+
to be a hint string.
685+
686+
=item * Arguments
687+
688+
List of strings to warn, followed by one argument representing a hint.
689+
If that argument is defined then it will be split on newlines and output
690+
line by line after the main warning.
691+
692+
=item * Return Value
693+
694+
None.
695+
696+
=back
697+
698+
=cut
699+
700+
sub WarnHint {
666701
my $self = shift;
702+
my $hint = pop;
667703
my $warn_line_number = $self->current_line_number();
668-
print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
704+
print STDERR join("",@_), " in $self->{filename}, line $warn_line_number\n";
705+
if ($hint) {
706+
print STDERR " ($_)\n" for split /\n/, $hint;
707+
}
669708
}
670709

671710
=head2 C<blurt()>

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

Lines changed: 40 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1332,6 +1332,46 @@ C<BAR::getit()> for this function.
13321332
OUTPUT:
13331333
timep
13341334

1335+
A warning will be produced when you create more than one alias to the same
1336+
value. This may be worked around in a backwards compatible way by creating
1337+
multiple defines which resolve to the same value, or with a modern version
1338+
of ExtUtils::ParseXS you can use a symbolic alias, which are denoted with
1339+
a C<< => >> instead of a C<< = >>. For instance you could change the above
1340+
so that the alias section looked like this:
1341+
1342+
ALIAS:
1343+
FOO::gettime = 1
1344+
BAR::getit = 2
1345+
BAZ::gettime => FOO::gettime
1346+
1347+
this would have the same effect as this:
1348+
1349+
ALIAS:
1350+
FOO::gettime = 1
1351+
BAR::getit = 2
1352+
BAZ::gettime = 1
1353+
1354+
except that the latter will produce warnings during the build process. A
1355+
mechanism that would work in a backwards compatible way with older
1356+
versions of our tool chain would be to do this:
1357+
1358+
#define FOO_GETTIME 1
1359+
#define BAR_GETIT 2
1360+
#define BAZ_GETTIME 1
1361+
1362+
bool_t
1363+
rpcb_gettime(host,timep)
1364+
char *host
1365+
time_t &timep
1366+
ALIAS:
1367+
FOO::gettime = FOO_GETTIME
1368+
BAR::getit = BAR_GETIT
1369+
BAZ::gettime = BAZ_GETTIME
1370+
INIT:
1371+
printf("# ix = %d\n", ix );
1372+
OUTPUT:
1373+
timep
1374+
13351375
=head2 The OVERLOAD: Keyword
13361376

13371377
Instead of writing an overloaded interface using pure Perl, you

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

Lines changed: 43 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
#!/usr/bin/perl
22

33
use strict;
4-
use Test::More tests => 22;
4+
use Test::More tests => 24;
55
use Config;
66
use DynaLoader;
77
use ExtUtils::CBuilder;
@@ -238,6 +238,48 @@ like $stderr, '/No INPUT definition/', "Exercise typemap error";
238238
is $count, 2, "Saw XS_MY_do definition the expected number of times";
239239
}
240240

241+
{ # Alias check
242+
my $pxs = ExtUtils::ParseXS->new;
243+
tie *FH, 'Foo';
244+
my $stderr = PrimitiveCapture::capture_stderr(sub {
245+
$pxs->process_file(
246+
filename => 'XSAlias.xs',
247+
output => \*FH,
248+
prototypes => 1);
249+
});
250+
my $content = tied(*FH)->{buf};
251+
my $count = 0;
252+
$count++ while $content=~/^XS_EUPXS\(XS_My_do\)\n\{/mg;
253+
is $stderr,
254+
"Warning: Aliases 'pox' and 'dox', 'lox' have"
255+
. " identical values in XSAlias.xs, line 9\n"
256+
. " (If this is deliberate use a symbolic alias instead.)\n"
257+
. "Warning: Conflicting duplicate alias 'pox' changes"
258+
. " definition from '1' to '2' in XSAlias.xs, line 10\n"
259+
. "Warning: Aliases 'docks' and 'dox', 'lox' have"
260+
. " identical values in XSAlias.xs, line 11\n",
261+
"Saw expected warnings from XSAlias.xs";
262+
263+
my $expect = quotemeta(<<'EOF_CONTENT');
264+
cv = newXSproto_portable("My::dachs", XS_My_do, file, "$");
265+
XSANY.any_i32 = 1;
266+
cv = newXSproto_portable("My::do", XS_My_do, file, "$");
267+
XSANY.any_i32 = 0;
268+
cv = newXSproto_portable("My::docks", XS_My_do, file, "$");
269+
XSANY.any_i32 = 1;
270+
cv = newXSproto_portable("My::dox", XS_My_do, file, "$");
271+
XSANY.any_i32 = 1;
272+
cv = newXSproto_portable("My::lox", XS_My_do, file, "$");
273+
XSANY.any_i32 = 1;
274+
cv = newXSproto_portable("My::pox", XS_My_do, file, "$");
275+
XSANY.any_i32 = 2;
276+
EOF_CONTENT
277+
$expect=~s/(?:\\[ ])+/\\s+/g;
278+
$expect=qr/$expect/;
279+
like $content, $expect, "Saw expected alias initialization";
280+
281+
#diag $content;
282+
}
241283
#####################################################################
242284

243285
sub Foo::TIEHANDLE { bless {}, 'Foo' }

‎dist/ExtUtils-ParseXS/t/XSAlias.xs

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
MODULE = My PACKAGE = My
2+
3+
void
4+
do(dbh)
5+
SV *dbh
6+
ALIAS:
7+
dox = 1
8+
lox => dox
9+
pox = 1
10+
pox = 2
11+
docks = 1
12+
dachs => lox
13+
CODE:
14+
{
15+
int x;
16+
++x;
17+
}

0 commit comments

Comments
 (0)