diff options
author | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
commit | 12679ab7d3c2a210f4123163671b532b8b55d5f9 (patch) | |
tree | 0060d13467186ad977f4e73488ee20dd6c0017ab /systems/texlive/tlnet/tlpkg/tlperl/lib/ExtUtils/ParseXS.pm | |
parent | 62170822e034fdd3f81de7274835d0d3b0467100 (diff) |
CTAN sync 202403150306
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/ExtUtils/ParseXS.pm')
-rw-r--r-- | systems/texlive/tlnet/tlpkg/tlperl/lib/ExtUtils/ParseXS.pm | 230 |
1 files changed, 189 insertions, 41 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/ExtUtils/ParseXS.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/ExtUtils/ParseXS.pm index d2205acd5a..0721582250 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/ExtUtils/ParseXS.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/ExtUtils/ParseXS.pm @@ -11,7 +11,7 @@ use Symbol; our $VERSION; BEGIN { - $VERSION = '3.43'; + $VERSION = '3.51'; 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(); @@ -690,10 +709,17 @@ EOF do_push => undef, } ) for grep $self->{in_out}->{$_} =~ /OUT$/, sort keys %{ $self->{in_out} }; - my $prepush_done; + my $outlist_count = @{ $outlist_ref }; + if ($outlist_count) { + my $ext = $outlist_count; + ++$ext if $self->{gotRETVAL} || $wantRETVAL; + print "\tXSprePUSH;"; + print "\tEXTEND(SP,$ext);\n"; + } # all OUTPUT done, so now push the return value on the stack if ($self->{gotRETVAL} && $self->{RETVAL_code}) { print "\t$self->{RETVAL_code}\n"; + print "\t++SP;\n" if $outlist_count; } elsif ($self->{gotRETVAL} || $wantRETVAL) { my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); @@ -708,8 +734,9 @@ EOF ); if (not $trgt->{with_size} and $trgt->{type} eq 'p') { # sv_setpv # PUSHp corresponds to sv_setpvn. Treat sv_setpv directly - print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; - $prepush_done = 1; + print "\tsv_setpv(TARG, $what);\n"; + print "\tXSprePUSH;\n" unless $outlist_count; + print "\tPUSHTARG;\n"; } else { my $tsize = $trgt->{what_size}; @@ -718,8 +745,8 @@ EOF qq("$tsize"), {var => $var, type => $self->{ret_type}} ); - print "\tXSprePUSH; PUSH$trgt->{type}($what$tsize);\n"; - $prepush_done = 1; + print "\tXSprePUSH;\n" unless $outlist_count; + print "\tPUSH$trgt->{type}($what$tsize);\n"; } } else { @@ -731,15 +758,13 @@ EOF do_setmagic => 0, do_push => undef, } ); + print "\t++SP;\n" if $outlist_count; } } $xsreturn = 1 if $self->{ret_type} ne "void"; my $num = $xsreturn; - my $c = @{ $outlist_ref }; - print "\tXSprePUSH;" if $c and not $prepush_done; - print "\tEXTEND(SP,$c);\n" if $c; - $xsreturn += $c; + $xsreturn += $outlist_count; $self->generate_output( { type => $self->{var_types}->{$_}, num => $num++, @@ -782,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; @@ -793,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"); #]] @@ -865,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); @@ -878,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 } @@ -890,7 +931,7 @@ MAKE_FETCHMETHOD_WORK print Q(<<"EOF"); ##ifdef __cplusplus -#extern "C" +#extern "C" { ##endif EOF @@ -953,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} }; @@ -992,6 +1042,9 @@ EOF ##endif #]] # +##ifdef __cplusplus +#} +##endif EOF warn("Please specify prototyping behavior for $self->{filename} (see perlxs manual)\n") @@ -1286,26 +1339,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'") @@ -1342,10 +1458,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; } } } @@ -1368,7 +1481,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}; } @@ -1779,11 +1892,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 @@ -1793,7 +1912,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 @@ -1804,6 +1923,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}); } @@ -1817,6 +1961,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 @@ -2022,8 +2169,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); |