Skip to content

ParseXS improvements #20496

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 7 commits into from
Nov 16, 2022
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions MANIFEST
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
130 changes: 114 additions & 16 deletions dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
Original file line number Diff line number Diff line change
Expand Up @@ -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);
Expand All @@ -31,6 +31,7 @@ use ExtUtils::ParseXS::Utilities qw(
analyze_preprocessor_statements
set_cond
Warn
WarnHint
current_line_number
blurt
death
Expand All @@ -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/ [({\[]
Expand Down Expand Up @@ -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' : '';
Expand Down Expand Up @@ -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}) =
Expand Down Expand Up @@ -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 */
Expand Down Expand Up @@ -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");
Expand Down Expand Up @@ -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'")
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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});
}
Expand All @@ -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
Expand Down
10 changes: 10 additions & 0 deletions dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pod
Original file line number Diff line number Diff line change
Expand Up @@ -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:
Expand Down Expand Up @@ -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()
Expand Down
2 changes: 1 addition & 1 deletion dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,7 @@ use strict;
use warnings;
use Symbol;

our $VERSION = '3.47';
our $VERSION = '3.48';

=head1 NAME

Expand Down
2 changes: 1 addition & 1 deletion dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
package ExtUtils::ParseXS::CountLines;
use strict;

our $VERSION = '3.47';
our $VERSION = '3.48';

our $SECTION_END_MARKER;

Expand Down
2 changes: 1 addition & 1 deletion dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@ package ExtUtils::ParseXS::Eval;
use strict;
use warnings;

our $VERSION = '3.47';
our $VERSION = '3.48';

=head1 NAME

Expand Down
Loading