rpms/perl-ExtUtils-ParseXS
7
0
Fork 0
Code Issues Pull Requests Releases Activity
f1dd99e5b2
perl-ExtUtils-ParseXS/ExtUtils-ParseXS-3.44-Upgrade-to-3.50.patch
Jitka Plesnikova 1e44113075 Upgrade to 3.50 as provided in perl-5.37.11
2023-05-17 12:30:51 +02:00

1165 lines
35 KiB
Diff
Raw Blame History

From 2f9bbf8d0bd95bb60498d0fe8b37ded3f5ac42f1 Mon Sep 17 00:00:00 2001
From: Jitka Plesnikova <jplesnik@redhat.com>
Date: Wed, 17 May 2023 09:25:56 +0200
Subject: [PATCH] Upgrade to 3.50
---
Changes | 3 +
lib/ExtUtils/ParseXS.pm | 201 ++++++++++++++++++++++++-----
lib/ExtUtils/ParseXS.pod | 10 ++
lib/ExtUtils/ParseXS/Constants.pm | 2 +-
lib/ExtUtils/ParseXS/CountLines.pm | 2 +-
lib/ExtUtils/ParseXS/Eval.pm | 2 +-
lib/ExtUtils/ParseXS/Utilities.pm | 81 +++++++++++-
lib/ExtUtils/Typemaps.pm | 4 +-
lib/ExtUtils/Typemaps/Cmd.pm | 2 +-
lib/ExtUtils/Typemaps/InputMap.pm | 2 +-
lib/ExtUtils/Typemaps/OutputMap.pm | 2 +-
lib/ExtUtils/Typemaps/Type.pm | 2 +-
lib/perlxs.pod | 53 +++++++-
t/001-basic.t | 166 +++++++++++++++++++++++-
t/002-more.t | 9 +-
t/003-usage.t | 2 +-
t/XSAlias.xs | 19 +++
t/XSFalsePositive.xs | 23 ++++
t/XSFalsePositive2.xs | 23 ++++
t/XSMore.xs | 18 +++
t/XSTightDirectives.xs | 21 +++
21 files changed, 596 insertions(+), 51 deletions(-)
create mode 100644 t/XSAlias.xs
create mode 100644 t/XSFalsePositive.xs
create mode 100644 t/XSFalsePositive2.xs
create mode 100644 t/XSTightDirectives.xs
diff --git a/Changes b/Changes
index c4da004..8a30751 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,8 @@
Revision history for Perl extension ExtUtils::ParseXS.
+3.45 - Fri Mar 4 22:42:03 2022
+ - GH #19320: Fix OVERLOAD and FALLBACK handling.
+
3.44 - Thu Jan 6 23:49:25 2022
- GH #19054: Always XSprePUSH when producing an output list.
- Use more descriptive variable names.
diff --git a/lib/ExtUtils/ParseXS.pm b/lib/ExtUtils/ParseXS.pm
index c3e8220..3975dd4 100644
--- a/lib/ExtUtils/ParseXS.pm
+++ b/lib/ExtUtils/ParseXS.pm
@@ -11,7 +11,7 @@ use Symbol;
our $VERSION;
BEGIN {
- $VERSION = '3.44';
+ $VERSION = '3.50';
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,10 @@ our @EXPORT_OK = qw(
##############################
# A number of "constants"
-
+our $DIE_ON_ERROR;
+our $AUTHOR_WARNINGS;
+$AUTHOR_WARNINGS = ($ENV{AUTHOR_WARNINGS} || 0)
+ unless defined $AUTHOR_WARNINGS;
our ($C_group_rex, $C_arg);
# Group in C (no support for comments or literals)
$C_group_rex = qr/ [({\[]
@@ -103,6 +107,8 @@ sub process_file {
typemap => [],
versioncheck => 1,
FH => Symbol::gensym(),
+ die_on_error => $DIE_ON_ERROR, # if true we die() and not exit() after errors
+ author_warnings => $AUTHOR_WARNINGS,
%options,
);
$args{except} = $args{except} ? ' TRY' : '';
@@ -119,9 +125,9 @@ sub process_file {
}
@{ $self->{XSStack} } = ({type => 'none'});
$self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ];
- $self->{Overload} = 0; # bool
+ $self->{Overloaded} = {}; # hashref of Package => Packid
+ $self->{Fallback} = {}; # hashref of Package => fallback setting
$self->{errors} = 0; # count
- $self->{Fallback} = '&PL_sv_undef';
# Most of the 1500 lines below uses these globals. We'll have to
# clean this up sometime, probably. For now, we just pull them out
@@ -133,6 +139,9 @@ sub process_file {
$self->{WantLineNumbers} = $args{linenumbers};
$self->{IncludedFiles} = {};
+ $self->{die_on_error} = $args{die_on_error};
+ $self->{author_warnings} = $args{author_warnings};
+
die "Missing required parameter 'filename'" unless $args{filename};
$self->{filepathname} = $args{filename};
($self->{dir}, $self->{filename}) =
@@ -301,6 +310,7 @@ EOM
$self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET';
$self->{ProtoThisXSUB} = $self->{WantPrototypes}; # states 0 (none), 1 (yes), 2 (empty prototype)
$self->{ScopeThisXSUB} = 0; # bool
+ $self->{OverloadsThisXSUB} = {}; # overloaded operators (as hash keys, to de-dup)
my $xsreturn = 0;
@@ -626,7 +636,16 @@ EOF
$self->print_section();
$self->death("PPCODE must be last thing") if @{ $self->{line} };
print "\tLEAVE;\n" if $self->{ScopeThisXSUB};
+ print "#if defined(__HP_cc) || defined(__HP_aCC)\n",
+ "#pragma diag_suppress 2111\n",
+ "#endif\n"
+ if $^O eq "hpux";
print "\tPUTBACK;\n\treturn;\n";
+ print "#if defined(__HP_cc) || defined(__HP_aCC)\n",
+ "#pragma diag_default 2111\n",
+ "#endif\n"
+ if $^O eq "hpux";
+
}
elsif ($self->check_keyword("CODE")) {
my $consumed_code = $self->print_section();
@@ -788,6 +807,10 @@ EOF
# if (errbuf[0])
# Perl_croak(aTHX_ errbuf);
EOF
+ print "#if defined(__HP_cc) || defined(__HP_aCC)\n",
+ "#pragma diag_suppress 2128\n",
+ "#endif\n"
+ if $^O eq "hpux";
if ($xsreturn) {
print Q(<<"EOF") unless $PPCODE;
@@ -799,6 +822,10 @@ EOF
# XSRETURN_EMPTY;
EOF
}
+ print "#if defined(__HP_cc) || defined(__HP_aCC)\n",
+ "#pragma diag_default 2128\n",
+ "#endif\n"
+ if $^O eq "hpux";
print Q(<<"EOF");
#]]
@@ -871,12 +898,20 @@ EOF
push(@{ $self->{InitFileCode} },
" (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
}
+
+ 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
- if ($self->{Overload}) { # make it 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_$self->{Packid}_nil); /* prototype to pass -Wmissing-prototypes */
-#XS_EUPXS(XS_$self->{Packid}_nil)
+#XS_EUPXS(XS_${packid}_nil); /* prototype to pass -Wmissing-prototypes */
+#XS_EUPXS(XS_${packid}_nil)
#{
# dXSARGS;
# PERL_UNUSED_VAR(items);
@@ -884,11 +919,11 @@ EOF
#}
#
EOF
- unshift(@{ $self->{InitFileCode} }, <<"MAKE_FETCHMETHOD_WORK");
- /* Making a sub named "$self->{Package}::()" allows the package */
- /* to be findable via fetchmethod(), and causes */
- /* overload::Overloaded("$self->{Package}") to return true. */
- (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto});
+ unshift(@{ $self->{InitFileCode} }, Q(<<"MAKE_FETCHMETHOD_WORK"));
+# /* Making a sub named "${package}::()" allows the package */
+# /* to be findable via fetchmethod(), and causes */
+# /* overload::Overloaded("$package") to return true. */
+# (void)newXS_deffile("${package}::()", XS_${packid}_nil);
MAKE_FETCHMETHOD_WORK
}
@@ -959,19 +994,28 @@ EOF
#
EOF
- print Q(<<"EOF") if ($self->{Overload});
+ 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 (sort keys %{ $self->{Overloaded} }) {
+ # once for each package with overloads
+ my $fallback = $self->{Fallback}->{$package} || "&PL_sv_undef";
+ print Q(<<"EOF");
# /* The magic for overload gets a GV* via gv_fetchmeth as */
# /* mentioned above, and looks in the SV* slot of it for */
# /* the "fallback" status. */
# sv_setsv(
-# get_sv( "$self->{Package}::()", TRUE ),
-# $self->{Fallback}
+# get_sv( "${package}::()", TRUE ),
+# $fallback
# );
EOF
+ }
+ }
print @{ $self->{InitFileCode} };
@@ -1292,26 +1336,89 @@ 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 and $self->{author_warnings}) {
+ # We do not warn about value collisions unless author_warnings
+ # are enabled. They aren't helpful to a module consumer, only
+ # the module author.
+ @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'")
@@ -1348,10 +1455,7 @@ sub OVERLOAD_handler {
next unless /\S/;
trim_whitespace($_);
while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
- $self->{Overload} = 1 unless $self->{Overload};
- my $overload = "$self->{Package}\::(".$1;
- push(@{ $self->{InitFileCode} },
- " (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
+ $self->{OverloadsThisXSUB}->{$1} = 1;
}
}
}
@@ -1374,7 +1478,7 @@ sub FALLBACK_handler {
# check for valid FALLBACK value
$self->death("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{$setting};
- $self->{Fallback} = $map{$setting};
+ $self->{Fallback}->{$self->{Package}} = $map{$setting};
}
@@ -1785,11 +1889,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
@@ -1799,7 +1909,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
@@ -1810,6 +1920,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});
}
@@ -1823,6 +1958,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
@@ -2028,8 +2166,9 @@ sub generate_output {
(my $ntype = $type) =~ s/\s*\*/Ptr/g;
$ntype =~ s/\(\)//g;
(my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
+ $type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes};
- my $eval_vars = {%$argsref, subtype => $subtype, ntype => $ntype, arg => $arg};
+ my $eval_vars = {%$argsref, subtype => $subtype, ntype => $ntype, arg => $arg, type => $type };
my $expr = $outputmap->cleaned_code;
if ($expr =~ /DO_ARRAY_ELEM/) {
my $subtypemap = $typemaps->get_typemap(ctype => $subtype);
diff --git a/lib/ExtUtils/ParseXS.pod b/lib/ExtUtils/ParseXS.pod
index 80bf13f..093a317 100644
--- a/lib/ExtUtils/ParseXS.pod
+++ b/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()
diff --git a/lib/ExtUtils/ParseXS/Constants.pm b/lib/ExtUtils/ParseXS/Constants.pm
index 5b73795..5acd1b0 100644
--- a/lib/ExtUtils/ParseXS/Constants.pm
+++ b/lib/ExtUtils/ParseXS/Constants.pm
@@ -3,7 +3,7 @@ use strict;
use warnings;
use Symbol;
-our $VERSION = '3.44';
+our $VERSION = '3.50';
=head1 NAME
diff --git a/lib/ExtUtils/ParseXS/CountLines.pm b/lib/ExtUtils/ParseXS/CountLines.pm
index a5b71f6..0282372 100644
--- a/lib/ExtUtils/ParseXS/CountLines.pm
+++ b/lib/ExtUtils/ParseXS/CountLines.pm
@@ -1,7 +1,7 @@
package ExtUtils::ParseXS::CountLines;
use strict;
-our $VERSION = '3.44';
+our $VERSION = '3.50';
our $SECTION_END_MARKER;
diff --git a/lib/ExtUtils/ParseXS/Eval.pm b/lib/ExtUtils/ParseXS/Eval.pm
index 8a3bd00..da323cf 100644
--- a/lib/ExtUtils/ParseXS/Eval.pm
+++ b/lib/ExtUtils/ParseXS/Eval.pm
@@ -2,7 +2,7 @@ package ExtUtils::ParseXS::Eval;
use strict;
use warnings;
-our $VERSION = '3.44';
+our $VERSION = '3.50';
=head1 NAME
diff --git a/lib/ExtUtils/ParseXS/Utilities.pm b/lib/ExtUtils/ParseXS/Utilities.pm
index 574031d..054cbb2 100644
--- a/lib/ExtUtils/ParseXS/Utilities.pm
+++ b/lib/ExtUtils/ParseXS/Utilities.pm
@@ -5,7 +5,7 @@ use Exporter;
use File::Spec;
use ExtUtils::ParseXS::Constants ();
-our $VERSION = '3.44';
+our $VERSION = '3.50';
our (@ISA, @EXPORT_OK);
@ISA = qw(Exporter);
@@ -21,6 +21,7 @@ our (@ISA, @EXPORT_OK);
analyze_preprocessor_statements
set_cond
Warn
+ WarnHint
current_line_number
blurt
death
@@ -654,18 +655,85 @@ 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 {
+ warn _MsgHint(@_);
+}
+
+=head2 C<_MsgHint()>
+
+=over 4
+
+=item * Purpose
+
+Constructs an exception message 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 concatenated
+line by line (parenthesized) after the main message.
+
+=item * Return Value
+
+The constructed string.
+
+=back
+
+=cut
+
+
+sub _MsgHint {
my $self = shift;
+ my $hint = pop;
my $warn_line_number = $self->current_line_number();
- print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
+ my $ret = join("",@_) . " in $self->{filename}, line $warn_line_number\n";
+ if ($hint) {
+ $ret .= " ($_)\n" for split /\n/, $hint;
+ }
+ return $ret;
}
=head2 C<blurt()>
@@ -703,8 +771,13 @@ sub blurt {
=cut
sub death {
- my $self = shift;
- $self->Warn(@_);
+ my $self = (@_);
+ my $message = _MsgHint(@_,"");
+ if ($self->{die_on_error}) {
+ die $message;
+ } else {
+ warn $message;
+ }
exit 1;
}
diff --git a/lib/ExtUtils/Typemaps.pm b/lib/ExtUtils/Typemaps.pm
index c6d5430..5d5aadb 100644
--- a/lib/ExtUtils/Typemaps.pm
+++ b/lib/ExtUtils/Typemaps.pm
@@ -2,7 +2,7 @@ package ExtUtils::Typemaps;
use 5.006001;
use strict;
use warnings;
-our $VERSION = '3.44';
+our $VERSION = '3.49';
require ExtUtils::ParseXS;
require ExtUtils::ParseXS::Constants;
@@ -378,7 +378,7 @@ sub remove_inputmap {
return $self->_remove($xstype, $self->{input_section}, $self->{input_lookup});
}
-=head2 remove_inputmap
+=head2 remove_outputmap
Removes an C<OUTPUT> entry from the typemap.
diff --git a/lib/ExtUtils/Typemaps/Cmd.pm b/lib/ExtUtils/Typemaps/Cmd.pm
index 3c4b4e5..0958920 100644
--- a/lib/ExtUtils/Typemaps/Cmd.pm
+++ b/lib/ExtUtils/Typemaps/Cmd.pm
@@ -2,7 +2,7 @@ package ExtUtils::Typemaps::Cmd;
use 5.006001;
use strict;
use warnings;
-our $VERSION = '3.44';
+our $VERSION = '3.49';
use ExtUtils::Typemaps;
diff --git a/lib/ExtUtils/Typemaps/InputMap.pm b/lib/ExtUtils/Typemaps/InputMap.pm
index 102fc9e..189cd55 100644
--- a/lib/ExtUtils/Typemaps/InputMap.pm
+++ b/lib/ExtUtils/Typemaps/InputMap.pm
@@ -2,7 +2,7 @@ package ExtUtils::Typemaps::InputMap;
use 5.006001;
use strict;
use warnings;
-our $VERSION = '3.44';
+our $VERSION = '3.49';
=head1 NAME
diff --git a/lib/ExtUtils/Typemaps/OutputMap.pm b/lib/ExtUtils/Typemaps/OutputMap.pm
index f9b5a86..5fadbec 100644
--- a/lib/ExtUtils/Typemaps/OutputMap.pm
+++ b/lib/ExtUtils/Typemaps/OutputMap.pm
@@ -2,7 +2,7 @@ package ExtUtils::Typemaps::OutputMap;
use 5.006001;
use strict;
use warnings;
-our $VERSION = '3.44';
+our $VERSION = '3.49';
=head1 NAME
diff --git a/lib/ExtUtils/Typemaps/Type.pm b/lib/ExtUtils/Typemaps/Type.pm
index 1a78c17..8d049c1 100644
--- a/lib/ExtUtils/Typemaps/Type.pm
+++ b/lib/ExtUtils/Typemaps/Type.pm
@@ -4,7 +4,7 @@ use strict;
use warnings;
require ExtUtils::Typemaps;
-our $VERSION = '3.44';
+our $VERSION = '3.49';
=head1 NAME
diff --git a/lib/perlxs.pod b/lib/perlxs.pod
index f1bd408..0441fcc 100644
--- a/lib/perlxs.pod
+++ b/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
@@ -2369,7 +2409,18 @@ or use the methods given in L<perlcall>.
=head1 XS VERSION
This document covers features supported by C<ExtUtils::ParseXS>
-(also known as C<xsubpp>) 3.13_01.
+(also known as C<xsubpp>) 3.50
+
+=head1 AUTHOR DIAGNOSTICS
+
+As of version 3.49 certain warnings are disabled by default. While developing
+you can set C<$ENV{AUTHOR_WARNINGS}> to true in your environment or in your
+Makefile.PL, or set C<$ExtUtils::ParseXS::AUTHOR_WARNINGS> to true via code, or
+pass C<< author_warnings=>1 >> into process_file() explicitly. Currently this will
+enable stricter alias checking but more warnings might be added in the future.
+The kind of warnings this will enable are only helpful to the author of the XS
+file, and the diagnostics produced will not include installation specific
+details so they are only useful to the maintainer of the XS code itself.
=head1 AUTHOR
diff --git a/t/001-basic.t b/t/001-basic.t
index 6651809..d983476 100644
--- a/t/001-basic.t
+++ b/t/001-basic.t
@@ -1,7 +1,7 @@
#!/usr/bin/perl
use strict;
-use Test::More tests => 18;
+use Test::More tests => 28;
use Config;
use DynaLoader;
use ExtUtils::CBuilder;
@@ -15,7 +15,10 @@ require_ok( 'ExtUtils::ParseXS' );
chdir('t') if -d 't';
push @INC, '.';
-use Carp; $SIG{__WARN__} = \&Carp::cluck;
+$ExtUtils::ParseXS::DIE_ON_ERROR = 1;
+$ExtUtils::ParseXS::AUTHOR_WARNINGS = 1;
+
+use Carp; #$SIG{__WARN__} = \&Carp::cluck;
# The linker on some platforms doesn't like loading libraries using relative
# paths. Android won't find relative paths, and system perl on macOS will
@@ -91,6 +94,7 @@ is( $seen, 1, "Line numbers created in output file, as intended" );
local $/ = undef;
seek($IN, 0, 0);
my $filecontents = <$IN>;
+ $filecontents =~ s/^#if defined\(__HP_cc\).*\n#.*\n#endif\n//gm;
my $good_T_BOOL_re =
qr|\QXS_EUPXS(XS_XSTest_T_BOOL)\E
.+?
@@ -190,6 +194,164 @@ like $stderr, '/No INPUT definition/', "Exercise typemap error";
}
#####################################################################
+{ # fourth block: https://github.com/Perl/perl5/issues/19661
+ my $pxs = ExtUtils::ParseXS->new;
+ tie *FH, 'Foo';
+ my ($stderr, $filename);
+ {
+ $filename = 'XSFalsePositive.xs';
+ $stderr = PrimitiveCapture::capture_stderr(sub {
+ $pxs->process_file(filename => $filename, output => \*FH, prototypes => 1);
+ });
+ TODO: {
+ local $TODO = 'GH 19661';
+ unlike $stderr,
+ qr/Warning: duplicate function definition 'do' detected in \Q$filename\E/,
+ "No 'duplicate function definition' warning observed in $filename";
+ }
+ }
+ {
+ $filename = 'XSFalsePositive2.xs';
+ $stderr = PrimitiveCapture::capture_stderr(sub {
+ $pxs->process_file(filename => $filename, output => \*FH, prototypes => 1);
+ });
+ TODO: {
+ local $TODO = 'GH 19661';
+ unlike $stderr,
+ qr/Warning: duplicate function definition 'do' detected in \Q$filename\E/,
+ "No 'duplicate function definition' warning observed in $filename";
+ }
+ }
+}
+
+#####################################################################
+
+{ # tight cpp directives
+ my $pxs = ExtUtils::ParseXS->new;
+ tie *FH, 'Foo';
+ my $stderr = PrimitiveCapture::capture_stderr(sub { eval {
+ $pxs->process_file(
+ filename => 'XSTightDirectives.xs',
+ output => \*FH,
+ prototypes => 1);
+ } or warn $@ });
+ my $content = tied(*FH)->{buf};
+ my $count = 0;
+ $count++ while $content=~/^XS_EUPXS\(XS_My_do\)\n\{/mg;
+ is $stderr, undef, "No error expected from TightDirectives.xs";
+ 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 of 1 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 of 1 in XSAlias.xs, line 11\n"
+ . "Warning: Aliases 'xunx' and 'do' have identical values"
+ . " of 0 - the base function in XSAlias.xs, line 13\n",
+ "Saw expected warnings from XSAlias.xs in AUTHOR_WARNINGS mode";
+
+ 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;
+ cv = newXSproto_portable("My::xukes", XS_My_do, file, "$");
+ XSANY.any_i32 = 0;
+ cv = newXSproto_portable("My::xunx", XS_My_do, file, "$");
+ XSANY.any_i32 = 0;
+EOF_CONTENT
+ $expect=~s/(?:\\[ ])+/\\s+/g;
+ $expect=qr/$expect/;
+ like $content, $expect, "Saw expected alias initialization";
+
+ #diag $content;
+}
+{ # Alias check with no dev warnings.
+ my $pxs = ExtUtils::ParseXS->new;
+ tie *FH, 'Foo';
+ my $stderr = PrimitiveCapture::capture_stderr(sub {
+ $pxs->process_file(
+ filename => 'XSAlias.xs',
+ output => \*FH,
+ prototypes => 1,
+ author_warnings => 0);
+ });
+ my $content = tied(*FH)->{buf};
+ my $count = 0;
+ $count++ while $content=~/^XS_EUPXS\(XS_My_do\)\n\{/mg;
+ is $stderr,
+ "Warning: Conflicting duplicate alias 'pox' changes"
+ . " definition from '1' to '2' in XSAlias.xs, line 10\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;
+ cv = newXSproto_portable("My::xukes", XS_My_do, file, "$");
+ XSANY.any_i32 = 0;
+ cv = newXSproto_portable("My::xunx", XS_My_do, file, "$");
+ XSANY.any_i32 = 0;
+EOF_CONTENT
+ $expect=~s/(?:\\[ ])+/\\s+/g;
+ $expect=qr/$expect/;
+ like $content, $expect, "Saw expected alias initialization";
+
+ #diag $content;
+}
+{
+ my $file = $INC{"ExtUtils/ParseXS.pm"};
+ $file=~s!ExtUtils/ParseXS\.pm\z!perlxs.pod!;
+ open my $fh, "<", $file
+ or die "Failed to open '$file' for read:$!";
+ my $pod_version = "";
+ while (defined(my $line= readline($fh))) {
+ if ($line=~/\(also known as C<xsubpp>\)\s+(\d+\.\d+)/) {
+ $pod_version = $1;
+ last;
+ }
+ }
+ close $fh;
+ ok($pod_version, "Found the version from perlxs.pod");
+ is($pod_version, $ExtUtils::ParseXS::VERSION,
+ "The version in perlxs.pod should match the version of ExtUtils::ParseXS");
+}
+
+#####################################################################
+
sub Foo::TIEHANDLE { bless {}, 'Foo' }
sub Foo::PRINT { shift->{buf} .= join '', @_ }
sub Foo::content { shift->{buf} }
diff --git a/t/002-more.t b/t/002-more.t
index 1ed93a0..f118f2c 100644
--- a/t/002-more.t
+++ b/t/002-more.t
@@ -9,7 +9,7 @@ use ExtUtils::CBuilder;
use attributes;
use overload;
-plan tests => 32;
+plan tests => 33;
my ($source_file, $obj_file, $lib_file);
@@ -19,7 +19,7 @@ ExtUtils::ParseXS->import('process_file');
chdir 't' if -d 't';
push @INC, '.';
-use Carp; $SIG{__WARN__} = \&Carp::cluck;
+use Carp; #$SIG{__WARN__} = \&Carp::cluck;
# See the comments about this in 001-basics.t
@INC = map { File::Spec->rel2abs($_) } @INC;
@@ -47,7 +47,7 @@ SKIP: {
}
SKIP: {
- skip "no dynamic loading", 28
+ skip "no dynamic loading", 29
if !$b->have_compiler || !$Config{usedl};
my $module = 'XSMore';
$lib_file = $b->link( objects => $obj_file, module_name => $module );
@@ -85,6 +85,9 @@ SKIP: {
ok overload::Overloaded(XSMore->new), 'the FALLBACK keyword';
is abs(XSMore->new), 42, 'the OVERLOAD keyword';
+ my $overload_sub_name = "XSMore::More::(+";
+ is prototype(\&$overload_sub_name), "", 'OVERLOAD following prototyped xsub';
+
my @a;
XSMore::hook(\@a);
is_deeply \@a, [qw(INIT CODE POSTCALL CLEANUP)], 'the INIT & POSTCALL & CLEANUP keywords';
diff --git a/t/003-usage.t b/t/003-usage.t
index 52b9903..f33e3e0 100644
--- a/t/003-usage.t
+++ b/t/003-usage.t
@@ -20,7 +20,7 @@ require_ok( 'ExtUtils::ParseXS' );
chdir('t') if -d 't';
push @INC, '.';
-use Carp; $SIG{__WARN__} = \&Carp::cluck;
+use Carp; #$SIG{__WARN__} = \&Carp::cluck;
# See the comments about this in 001-basics.t
@INC = map { File::Spec->rel2abs($_) } @INC;
diff --git a/t/XSAlias.xs b/t/XSAlias.xs
new file mode 100644
index 0000000..fcd98e2
--- /dev/null
+++ b/t/XSAlias.xs
@@ -0,0 +1,19 @@
+MODULE = My PACKAGE = My
+
+void
+do(dbh)
+ SV *dbh
+ALIAS:
+ dox = 1
+ lox => dox
+ pox = 1
+ pox = 2
+ docks = 1
+ dachs => lox
+ xunx = 0
+ xukes => do
+CODE:
+{
+ int x;
+ ++x;
+}
diff --git a/t/XSFalsePositive.xs b/t/XSFalsePositive.xs
new file mode 100644
index 0000000..87a9330
--- /dev/null
+++ b/t/XSFalsePositive.xs
@@ -0,0 +1,23 @@
+MODULE = My PACKAGE = My
+
+#ifdef MYDEF123
+
+void
+do(dbh)
+ SV *dbh
+CODE:
+{
+ int x;
+ ++x;
+}
+
+#endif
+
+void
+do(dbh)
+ SV *dbh
+CODE:
+{
+ int x;
+ ++x;
+}
diff --git a/t/XSFalsePositive2.xs b/t/XSFalsePositive2.xs
new file mode 100644
index 0000000..4e0ca7e
--- /dev/null
+++ b/t/XSFalsePositive2.xs
@@ -0,0 +1,23 @@
+MODULE = My PACKAGE = My
+
+#ifdef MYDEF123
+
+void
+do(xdbh)
+ SV *xdbh
+CODE:
+{
+ int x;
+ ++x;
+}
+
+#endif
+
+void
+do(dbh)
+ SV *dbh
+CODE:
+{
+ int x;
+ ++x;
+}
diff --git a/t/XSMore.xs b/t/XSMore.xs
index f8413f4..b48cfa2 100644
--- a/t/XSMore.xs
+++ b/t/XSMore.xs
@@ -30,6 +30,10 @@ This parts are ignored.
# define PERL_UNUSED_VAR(x) ((void)x)
#endif
+/* Newx was introduced in 5.8.8, would also be in ppport.h */
+#ifndef Newx
+# define Newx(v,n,t) New(0,v,n,t)
+#endif
STATIC void
@@ -251,3 +255,17 @@ INCLUDE: XSInclude.xsh
# for testing #else directive
#endif
+
+MODULE=XSMore PACKAGE=XSMore::More
+
+void
+dummy()
+PROTOTYPE: $$$$$
+CODE:
+ NOOP;
+
+void
+should_not_have_prototype()
+OVERLOAD: +
+CODE:
+ NOOP;
diff --git a/t/XSTightDirectives.xs b/t/XSTightDirectives.xs
new file mode 100644
index 0000000..aa83f12
--- /dev/null
+++ b/t/XSTightDirectives.xs
@@ -0,0 +1,21 @@
+MODULE = My PACKAGE = My
+
+#ifdef MYDEF123
+void
+do(dbh)
+ SV *dbh
+CODE:
+{
+ int x;
+ ++x;
+}
+#else
+void
+do(dbh)
+ SV *dbh
+CODE:
+{
+ int x;
+ ++x;
+}
+#endif
--
2.40.1
Reference in New Issue View Git Blame Copy Permalink