From 2f9bbf8d0bd95bb60498d0fe8b37ded3f5ac42f1 Mon Sep 17 00:00:00 2001 From: Jitka Plesnikova 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 I have no clue what this does. Strips function prefixes? +=item B + +Normally ExtUtils::ParseXS will terminate the program with an C 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 + +=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 @@ -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 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 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. =head1 XS VERSION This document covers features supported by C -(also known as C) 3.13_01. +(also known as C) 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\)\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