diff --git a/MANIFEST b/MANIFEST index d20194933eec..c38d95833f2b 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4201,57 +4201,58 @@ dist/ExtUtils-ParseXS/lib/ExtUtils/xsubpp External subroutine preprocessor dist/ExtUtils-ParseXS/lib/perlxs.pod Perl XS application programming interface dist/ExtUtils-ParseXS/lib/perlxstut.pod Perl XS tutorial dist/ExtUtils-ParseXS/lib/perlxstypemap.pod Perl XS C/Perl type conversion tools -dist/ExtUtils-ParseXS/t/001-basic.t See if ExtUtils::ParseXS works -dist/ExtUtils-ParseXS/t/002-more.t Extended ExtUtils::ParseXS testing -dist/ExtUtils-ParseXS/t/003-usage.t ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/101-standard_typemap_locations.t ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/102-trim_whitespace.t ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/103-tidy_type.t ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/104-map_type.t ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/105-valid_proto_string.t ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/106-process_typemaps.t ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/108-map_type.t ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/112-set_cond.t ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/113-check_cond_preproc_statements.t ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/114-blurt_death_Warn.t ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/115-avoid-noise.t ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/501-t-compile.t ExtUtils::Typemaps tests -dist/ExtUtils-ParseXS/t/510-t-bare.t ExtUtils::Typemaps tests -dist/ExtUtils-ParseXS/t/511-t-whitespace.t ExtUtils::Typemaps tests -dist/ExtUtils-ParseXS/t/512-t-file.t ExtUtils::Typemaps tests -dist/ExtUtils-ParseXS/t/513-t-merge.t ExtUtils::Typemaps tests -dist/ExtUtils-ParseXS/t/514-t-embed.t ExtUtils::Typemaps tests -dist/ExtUtils-ParseXS/t/515-t-cmd.t ExtUtils::Typemaps tests -dist/ExtUtils-ParseXS/t/516-t-clone.t ExtUtils::Typemaps tests -dist/ExtUtils-ParseXS/t/517-t-targetable.t ExtUtils::Typemaps tests -dist/ExtUtils-ParseXS/t/600-t-compat.t ExtUtils::Typemaps tests -dist/ExtUtils-ParseXS/t/data/b.typemap ExtUtils::Typemaps test data -dist/ExtUtils-ParseXS/t/data/combined.typemap ExtUtils::Typemaps test data -dist/ExtUtils-ParseXS/t/data/confl_repl.typemap ExtUtils::Typemaps test data -dist/ExtUtils-ParseXS/t/data/confl_skip.typemap ExtUtils::Typemaps test data -dist/ExtUtils-ParseXS/t/data/conflicting.typemap ExtUtils::Typemaps test data -dist/ExtUtils-ParseXS/t/data/other.typemap ExtUtils::Typemaps test data -dist/ExtUtils-ParseXS/t/data/perl.typemap ExtUtils::Typemaps test data -dist/ExtUtils-ParseXS/t/data/simple.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/000-version.t See if ExtUtils::ParseXS loads and has the right version num +dist/ExtUtils-ParseXS/t/001-parse-basic.t See if ExtUtils::ParseXS basic parsing works +dist/ExtUtils-ParseXS/t/002-parse-file-scope.t test ExtUtils::ParseXS file-scoped syntax +dist/ExtUtils-ParseXS/t/003-parse-file-scope-keywords.t test ExtUtils::ParseXS file-scoped keywords syntax +dist/ExtUtils-ParseXS/t/004-parse-xsub-declaration.t test ExtUtils::ParseXS XSUB declaration syntax +dist/ExtUtils-ParseXS/t/005-parse-parameters.t test ExtUtils::ParseXS XSUB parameter syntax +dist/ExtUtils-ParseXS/t/006-parse-return-type.t test ExtUtils::ParseXS XSUB return type +dist/ExtUtils-ParseXS/t/007-parse-input-output.t test ExtUtils::ParseXS XSUB INPUT and OUTPUT keywords +dist/ExtUtils-ParseXS/t/008-parse-xsub-keywords.t test ExtUtils::ParseXS XSUB keywords +dist/ExtUtils-ParseXS/t/009-parse-c-plusplus.t test ExtUtils::ParseXS C++ support +dist/ExtUtils-ParseXS/t/101-api-standard_typemap_locations.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/102-api-trim_whitespace.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/103-api-tidy_type.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/104-api-map_type.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/105-api-valid_proto_string.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/106-api-process_typemaps.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/113-api-check_cond_preproc_statements.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/114-api-blurt_death_Warn.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/301-run-basic.t See if ExtUtils::ParseXS can compile and run a file +dist/ExtUtils-ParseXS/t/302-run-more.t Extended ExtUtils::ParseXS compile and run +dist/ExtUtils-ParseXS/t/303-run-usage.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/501-typemaps-compile.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/510-typemaps-bare.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/511-typemaps-whitespace.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/512-typemaps-file.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/513-typemaps-merge.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/514-typemaps-embed.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/515-typemaps-cmd.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/516-typemaps-clone.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/517-typemaps-targetable.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/518-typemaps-compat.t ExtUtils::Typemaps tests dist/ExtUtils-ParseXS/t/lib/ExtUtils/Typemaps/Test.pm ExtUtils::Typemaps tests dist/ExtUtils-ParseXS/t/lib/IncludeTester.pm ExtUtils::ParseXS testing utility dist/ExtUtils-ParseXS/t/lib/PrimitiveCapture.pm Primitive STDOUT/ERR capturing for tests +dist/ExtUtils-ParseXS/t/lib/TestMany.pm Tool for running XS parser tests dist/ExtUtils-ParseXS/t/lib/TypemapTest/Foo.pm ExtUtils::Typemaps tests -dist/ExtUtils-ParseXS/t/pseudotypemap1 A test-typemap +dist/ExtUtils-ParseXS/t/test_typemaps/b.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/test_typemaps/combined.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/test_typemaps/confl_repl.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/test_typemaps/confl_skip.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/test_typemaps/conflicting.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/test_typemaps/other.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/test_typemaps/perl.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/test_typemaps/simple.typemap ExtUtils::Typemaps test data 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/XSloop.xsh Test file for ExtUtils::ParseXS tests dist/ExtUtils-ParseXS/t/XSMore.xs Test file for ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/XSNoMap.xs 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 dist/Filter-Simple/Changes History of change for Filter::Simple dist/Filter-Simple/lib/Filter/Simple.pm Simple frontend to Filter::Util::Call dist/Filter-Simple/Makefile.PL Build Filter::Simple diff --git a/dist/ExtUtils-ParseXS/Changes b/dist/ExtUtils-ParseXS/Changes index 72254ea304c1..fd6783d16fb0 100644 --- a/dist/ExtUtils-ParseXS/Changes +++ b/dist/ExtUtils-ParseXS/Changes @@ -1,13 +1,25 @@ Revision history for Perl extension ExtUtils::ParseXS. -3.60 +3.62 + - allow 'length(foo)' to work with any 'foo' type that has + 'SvPV_nolen()' or similar in its typemap, not just that it maps + to T_PV + - improve warning and error messages + - improve test coverage + - reorganise t/ + +3.61 Fri Jan 9 2026 + - rewrite perlxs.pod + - finish refactoring to use an Abstract Syntax Tree (AST) internally + +3.60 Fri Sep 26 2025 - Fix INTERFACE for C23 - support perl package names in INTERFACE - Cleanup typemap file-finding code and change priority - Revert throwing an exception when combining the length operator with a typemap other than T_PV -3.59 +3.59 Fri Sep 5 2025 - Throw an exception when combining the length operator with a typemap other than T_PV diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm index e2ada35f6411..80a3e960df09 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm @@ -97,6 +97,7 @@ use ExtUtils::ParseXS::Utilities qw( current_line_number blurt death + deathHint escape_file_for_line_directive report_typemap_failure ); diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm index 9957236d3fdd..045820b09a69 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm @@ -1,5 +1,18 @@ package ExtUtils::ParseXS::CountLines; + +# Private helper module. It is used to tie a file handle, and +# whenever lines are written to it, lines which match the +# +# ExtUtils::ParseXS::CountLines->end_marker() +# +# token are replaced with: +# +# #line NNN file.c +# +# where NNN is the count of lines written so far. + use strict; +use warnings; our $VERSION = '3.62'; @@ -40,7 +53,7 @@ sub PRINTF { sub DESTROY { # Not necessary if we're careful to end with a "\n" my $self = shift; - print {$self->{fh}} $self->{buffer}; + print {$self->{fh}} $self->{buffer} if length $self->{buffer}; } sub UNTIE { diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Node.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Node.pm index 6d9a41d79cd2..ec5ece0bf8e0 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Node.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Node.pm @@ -755,7 +755,7 @@ sub parse { push @{$self->{kids}}, $node; } - warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n"; + warn "Warning: no MODULE line found in XS file $pxs->{in_filename}\n"; return; } @@ -1173,8 +1173,8 @@ sub parse { # Parse branches of a CPP conditionals within a nested scope if (not $node->{is_if}) { - $pxs->death("Error: '". $node->{directive} - . "' with no matching 'if'") + $pxs->death("Error: '#". $node->{directive} + . "' with no matching '#if'") if $self->{type} ne 'if'; # we should already be within a nested scope; this @@ -1207,7 +1207,8 @@ sub parse { && $last->{is_cond} && !$last->{is_if} ) { - $pxs->death("Error: Unterminated '#if/#ifdef/#ifndef'") + $pxs->death( "Error: Unterminated '#$node->{directive}'" + . " from line $node->{line_no}") } # Move the CPP line which terminated the branch from @@ -1230,33 +1231,52 @@ sub parse { next; } - # die if the next line is indented: all file-scoped things (CPP, + my $file_scoped_keywords = + "BOOT|REQUIRE|PROTOTYPES|EXPORT_XSUB_SYMBOLS|FALLBACK" + . "|VERSIONCHECK|INCLUDE|INCLUDE_COMMAND|SCOPE|TYPEMAP"; + + # Die if the next line is indented: all file-scoped things (CPP, # keywords, XSUB starts) are supposed to start on column 1 # (although see the comment below about multiple parse_keywords() # iterations sneaking in indented keywords). # - # The text of the error message is based around a common reason - # for an indented line to appear in file scope: this is due to an - # XSUB being prematurely truncated by fetch_para(). For example in - # the code below, the coder wants the foo and bar lines to both be - # part of the same CODE block. But the XS parser sees the blank - # line followed by the '#ifdef' on column 1 as terminating the - # current XSUB. So the bar() line is treated as being in file - # scope and dies because it is indented. - # - # |int f() - # | CODE: - # | foo(); - # | - # |#ifdef USE_BAR - # | bar(); - # |#endif - $pxs->death( - "Code is not inside a function" - ." (maybe last function was ended by a blank line " - ." followed by a statement on column one?)") - if $pxs->{line}->[0] =~ /^\s/; + if ($pxs->{line}[0] =~ /^\s/) { + # Try to customise the error message based around why this + # line is indented, to better hint to the user what the + # problem is. + + if ($pxs->{line}[0] =~ /^\s+($file_scoped_keywords)\s*:/) { + $pxs->death( + "Error: file-scoped keywords should not be indented"); + } + + # The text of the error message is based around a common reason + # for an indented line to appear in file scope: this is due to an + # XSUB being prematurely truncated by fetch_para(). For example in + # the code below, the coder wants the foo and bar lines to both be + # part of the same CODE block. But the XS parser sees the blank + # line followed by the '#ifdef' on column 1 as terminating the + # current XSUB. So the bar() line is treated as being in file + # scope and dies because it is indented. + # + # |int f() + # | CODE: + # | foo(); + # | + # |#ifdef USE_BAR + # | bar(); + # |#endif + + $pxs->deathHint( + "Error: file-scoped directives must not be indented", + $self->Q(<{lines} = [ @{$pxs->{line}} ]; @{$pxs->{line}} = (); - # Ignore any text following the keyword on the same line. - # XXX this quietly ignores any such text - really it should - # warn, but not yet for backwards compatibility. - shift @{$self->{lines}}; + # Text following the keyword is ignored rather than being treated + # as the first line of code. + my $line0 = shift @{$self->{lines}}; + $pxs->Warn("Warning: text after keyword ignored: '$line0'") + if defined $line0 && $line0 =~ /\S/; 1; } @@ -1945,7 +1965,7 @@ sub parse { my $num = 0; # the number of CASE+bodies seen my $seen_bare_xbody = 0; # seen a previous body without a CASE - my $case_had_cond; # the previous CASE had a condition + my $case_had_cond = 1; # the previous CASE had a condition # Repeatedly look for CASE or XSUB body. while (1) { @@ -1959,11 +1979,16 @@ sub parse { if (defined $case) { $case->{num} = ++$num; - $pxs->blurt("Error: 'CASE:' after unconditional 'CASE:'") - if $num > 1 && ! $case_had_cond; + + if ($seen_bare_xbody) { + $pxs->blurt("Error: no 'CASE:' at top of function"); + $seen_bare_xbody = 0; + } + + unless ($case_had_cond) { + $pxs->blurt("Error: 'CASE:' after unconditional 'CASE:'"); + } $case_had_cond = length $case->{cond}; - $pxs->blurt("Error: no 'CASE:' at top of function") - if $seen_bare_xbody; } else { $seen_bare_xbody = 1; @@ -2007,6 +2032,14 @@ sub parse { unless defined $self->{map_alias_name_to_value}{$pname}; } + # per-XSUB sanity checks + + if ( $self->{map_interface_name_short_to_original} + && $self->{map_alias_name_to_value}) + { + $pxs->blurt("Error: only one of ALIAS and INTERFACE can be used per XSUB"); + } + 1; } @@ -2330,7 +2363,8 @@ sub parse { my ($class, $name, $params_text, $const) = ($1, $2, $3, $4); if (defined $const and !defined $class) { - $pxs->blurt("const modifier only allowed on XSUBs which are C++ methods"); + $pxs->blurt( + "Error: const modifier only allowed on XSUBs which are C++ methods"); undef $const; } @@ -2454,7 +2488,15 @@ sub parse { # a function definition needs at least 2 lines unless (@{$pxs->{line}}) { - $pxs->blurt("Error: function definition too short '$line'"); + if ($line =~ /^([A-Z][A-Z_]+):/) { + # It's possibly a mistyped keyword: give a more specific + # error message: + $pxs->death("Error: unrecognised keyword '$1'"); + return; + } + # Generic error message: + $pxs->deathHint("Error: unrecognised line: '$line'", + "possible start of a truncated XSUB definition?"); return; } @@ -2501,8 +2543,8 @@ BEGIN { $build_subclass->( 'default_usage', # Str: how to report default value in "usage:..." error 'is_ansi', # Bool: param's type was specified in signature 'is_length', # Bool: param is declared as 'length(foo)' in signature - 'has_length', # Bool: this param has a matching 'length(foo)' - # parameter in the signature + 'length_param', # Obj: 'foo' param's matching 'length(foo)' parameter + # node object, if any 'len_name' , # Str: the 'foo' in 'length(foo)' in signature 'is_synthetic', # Bool: var like 'THIS': we pretend it was in the sig @@ -2539,12 +2581,12 @@ sub parse { my $param_text = shift; $self->SUPER::parse($pxs); # set file/line_no - $_ = $param_text; # Decompose parameter into its components. # Note that $name can be either 'foo' or 'length(foo)' my ($out_type, $type, $name, $sp1, $sp2, $default) = + $param_text =~ /^ (?: (IN|IN_OUT|IN_OUTLIST|OUT|OUTLIST) @@ -2564,13 +2606,13 @@ sub parse { /x; unless (defined $name) { - if (/^ SV \s* \* $/x) { + if ($param_text =~ /^ SV \s* \* $/x) { # special-case SV* as a placeholder for backwards # compatibility. $self->{var} = 'SV *'; return 1; } - $pxs->blurt("Error: unparseable XSUB parameter: '$_'"); + $pxs->blurt("Error: unparseable XSUB parameter: '$param_text'"); return; } @@ -2610,13 +2652,13 @@ sub parse { # Process optional IN/OUT etc modifier + my $orig_out_type = $out_type; if (defined $out_type) { - if ($pxs->{config_allow_inout}) { - $out_type = $out_type eq 'IN' ? '' : $out_type; - } - else { - $pxs->blurt("Error: parameter IN/OUT modifier not allowed under -noinout"); - } + $pxs->blurt( + "Error: parameter IN/OUT modifier not allowed under -noinout") + unless $pxs->{config_allow_inout}; + + $out_type = $out_type eq 'IN' ? '' : $out_type; } else { $out_type = ''; @@ -2631,36 +2673,53 @@ sub parse { # Process 'length(foo)' pseudo-parameter - my $is_length; my $len_name; if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) { - if ($pxs->{config_allow_argtypes}) { - $len_name = $1; - $is_length = 1; - if (defined $default) { - $pxs->blurt( "Error: default value not allowed on " - . "length() parameter '$len_name'"); - undef $default; - } + $pxs->blurt( "Error: length() pseudo-parameter not allowed " + . "under -noargtypes") + unless $pxs->{config_allow_argtypes}; + + $len_name = $1; + + if (defined $default) { + $pxs->blurt( "Error: default value not allowed on " + . "length() parameter '$len_name'"); + undef $default; } - else { - $pxs->blurt( "Error: length() pseudo-parameter not allowed " - . "under -noargtypes"); + unless (defined $type) { + $pxs->blurt( + "Error: length($len_name) doesn't have a type specified"); + $type = 'STRLEN'; # stop cascading problems while + # blurting the rest of the file + } + + if (defined $orig_out_type) { + # Ban IN_OUT etc with length(). + $pxs->blurt( "Error: '$orig_out_type' modifier can't be used" + . " with length($len_name)"); + $out_type = ''; # avoid cascading errors } + + $self->{no_init} = 1; + $self->{is_length} = 1; + $self->{len_name} = $len_name; + # This is the C variable which will have it's + # value set to the length of the string, + # then used as an arg in an autocall: + $self->{var} = "XSauto_length_of_$len_name"; + + # Note that cross-checking with the foo parameter associated with + # length(foo) is done near the end of Node::Params::parse(), after + # all params have been parsed. } - # Handle ANSI params: those which have a type or 'length(s)', + # Mark ANSI params: those which have a type (including 'length(s)') # and which thus don't need a matching INPUT line. - if (defined $type or $is_length) { # 'int foo' or 'length(foo)' - @$self{qw(type is_ansi)} = ($type, 1); - - if ($is_length) { - $self->{no_init} = 1; - $self->{is_length} = 1; - $self->{len_name} = $len_name; - } + if (defined $type) { # 'int foo' or 'int length(foo)' + $self->{type} = $type; + $self->{is_ansi} = 1; } $self->{in_out} = $out_type if length $out_type; @@ -2671,9 +2730,12 @@ sub parse { my $report_def = ''; if (defined $default) { + $pxs->death("Error: missing default value expression for '$name'") + unless $default =~ /\S/; + # The default expression for reporting usage. For backcompat, # sometimes preserve the spaces either side of the '=' - $report_def = ((defined $type or $is_length) ? '' : $sp1) + $report_def = ($self->{is_ansi} ? '' : $sp1) . "=$sp2$default"; $self->{default_usage} = $report_def; $self->{default} = $default; @@ -2763,7 +2825,6 @@ sub lookup_input_typemap { my ($type, $arg_num, $var, $init, $no_init, $default) = @{$self}{qw(type arg_num var init no_init default)}; - $var = "XSauto_length_of_$self->{len_name}" if $self->{is_length}; my $arg = $pxs->ST($arg_num); # whitespace-tidy the type @@ -2837,17 +2898,6 @@ sub lookup_input_typemap { $xstype =~ s/OBJ$/REF/ || $xstype =~ s/^T_REF_IV_PTR$/T_PTRREF/ if $xsub->{decl}{name} =~ /DESTROY$/; - # For a string-ish parameter foo, if length(foo) was also declared - # as a pseudo-parameter, then override the normal typedef - which - # would emit SvPV_nolen(...) - and instead, emit SvPV(..., - # STRLEN_length_of_foo) - if ($xstype eq 'T_PV' and $self->{has_length}) { - die "default value not supported with length(NAME) supplied" - if defined $default; - return "($type)SvPV($arg, STRLEN_length_of_$var);", - $eval_vars, 0; - } - # Get the ExtUtils::Typemaps::InputMap object associated with the # xstype. This contains the template of the code to be embedded, # e.g. 'SvPV_nolen($arg)' @@ -2908,6 +2958,53 @@ sub lookup_input_typemap { # *typemap* is evalled. @$eval_vars{qw(ntype subtype argoff)} = ($ntype, $subtype, $argoff); $init_template = $expr; + + # For a parameter foo, if length(foo) was also declared as a + # pseudo-parameter, then try to modify the normal typemap, which + # we would expect to contain SvPV_nolen(...) or similar, into this + # form instead: SvPV(..., STRLEN_length_of_foo). + # Croak if this isn't possible. + # Just accept the typemap as-is if it already contains the correct + # STRLEN_length_of_ entry. + + if ($self->{length_param}) { + if ($expr =~ /\bSTRLEN_length_of_\$var\b/) { + # leave as-is + } + else { + unless ($expr =~ + s{ \b + (SvPV\w*)_nolen(\w*) + \( + \s*\$arg\s* + \) + } + {$1$2(\$arg, STRLEN_length_of_\$var)}x + ) { + $pxs->deathHint( + "Error: can't modify input typemap for" + . " length($self->{var})", + <{var}' has an associated length($self->{var}) +pseudo-parameter. In cases like this, the XS parser attempts to modify +a typemap entry such as + + \$var = (\$type)SvPV_nolen(\$arg) + +into a similar one which also sets a length, such as + + \$var = (\$type)SvPV(\$arg, STRLEN_length_of_\$var) + +In this case, the following typemap did not contain a recognised +SVPV_nolen() variant: + + $expr +EOF + } + } + } + + $init_template = $expr; } return ($init_template, $eval_vars, 1); @@ -3156,30 +3253,39 @@ sub as_input_code { my $arg = $pxs->ST($arg_num); + + # For this construct: 'foo(char *s, int length(s))', ... + if ($self->{is_length}) { - # Process length(foo) parameter. - # Basically for something like foo(char *s, int length(s)), - # create *two* local C vars: one with STRLEN type, and one with the - # type specified in the signature. Eventually, generate code looking - # something like: - # STRLEN STRLEN_length_of_s; - # int XSauto_length_of_s; - # char *s = (char *)SvPV(ST(0), STRLEN_length_of_s); - # XSauto_length_of_s = STRLEN_length_of_s; - # RETVAL = foo(s, XSauto_length_of_s); + # ... the call for the 'length(s)' pseudo-parameter should + # emit nothing ... + return; + } + elsif ($self->{length_param}) { + # ... while the call for the 's' parameter should emit a (possibly + # modified) declaration and init as normal, but also some extra + # lines. In total this parameter should emit code something like: # - # Note that the SvPV() code line is generated via a separate call to - # this sub with s as the var (as opposed to *this* call, which is - # handling length(s)), by overriding the normal T_PV typemap (which - # uses PV_nolen()). + # STRLEN STRLEN_length_of_s; + # int XSauto_length_of_s; + # char * s = (char *)SvPV(ST(0), STRLEN_length_of_s); + # + # XSauto_length_of_s = STRLEN_length_of_s; - my $name = $self->{len_name}; + my $lenp = $self->{length_param}; + my $xsauto_var = $lenp->{var}; + print "\tSTRLEN\tSTRLEN_length_of_$var;\n"; + print "\t$lenp->{type}\t$xsauto_var;\n"; - print "\tSTRLEN\tSTRLEN_length_of_$name;\n"; - # defer this line until after all the other declarations + # The "var = SvPV()" line will be emitted by the main body of this + # function. Note that the T_PV typemap entry will have already + # been overridden in lookup_input_typemap() during parse time + # to change SvPV_nolen() to SvPV() or similar. + # + # The final assign should be deferred to come after all + # declarations. $xbody->{input_part}{deferred_code_lines} .= - "\n\tXSauto_length_of_$name = STRLEN_length_of_$name;\n"; - $var = "XSauto_length_of_$name"; + "\n\t$xsauto_var = STRLEN_length_of_$var;\n"; } # Emit the variable's type and name. @@ -3860,7 +3966,7 @@ sub parse { # $C_arg regex doesn't work. This code path should ideally # never be reached, and indicates a design weakness in $C_arg. @param_texts = split(/\s*,\s*/, $params_text); - Warn($pxs, "Warning: cannot parse parameter list " + $pxs->Warn( "Warning: cannot parse parameter list " . "'$params_text', fallback to split"); } } @@ -3956,13 +4062,26 @@ sub parse { $self->{nargs} = $nargs; $self->{min_args} = $nargs - $opt_args; - # for each parameter of the form 'length(foo)', mark the corresponding - # 'foo' parameter as 'has_length', or error out if foo not found. + # for each parameter of the form 'length(foo)', set 'length_param' in + # the corresponding 'foo' parameter to point to that length parameter + # object, or error out if foo not found. for my $param (@{$self->{kids}}) { next unless $param->{is_length}; my $name = $param->{len_name}; if (exists $self->{names}{$name}) { - $self->{names}{$name}{has_length} = 1; + $self->{names}{$name}{length_param} = $param; + + $pxs->blurt("Error: length() on placeholder parameter '$name'") + unless defined $self->{names}{$name}{type}; + + $pxs->blurt( "Error: default value for $name not allowed" + . " when length($name) also present") + if defined $self->{names}{$name}{default}; + + my $in_out = $self->{names}{$name}{in_out}; + $pxs->blurt( "Error: '$in_out' modifier on '$name'" + . " can't be used with length()") + if defined $in_out and $in_out !~ /^IN/; } else { $pxs->blurt("Error: length() on non-parameter '$name'"); @@ -4016,12 +4135,6 @@ sub C_func_signature { # type) and has become semi-real. && !($param->{var} eq 'RETVAL' && defined($param->{arg_num})); - if ($param->{is_length}) { - push @args, "XSauto_length_of_$param->{len_name}"; - push @types, $param->{type}; - next; - } - if ($param->{var} eq 'SV *') { #backcompat placeholder $pxs->blurt("Error: parameter 'SV *' not valid as a C argument"); @@ -4034,7 +4147,9 @@ sub C_func_signature { # Ignore fake/alien stuff, except an OUTLIST arg, which # isn't passed from perl (so no arg_num), but *is* passed to # the C function and then back to perl. - next unless defined $param->{arg_num} or $io eq 'OUTLIST'; + next unless defined $param->{arg_num} + or $io eq 'OUTLIST' + or $param->{is_length}; my $a = $param->{var}; $a = "&$a" if $param->{is_addr} or $io =~ /OUT/; @@ -4325,17 +4440,9 @@ EOF } # Emit declaration/init code for any parameters which were - # declared with a type or length(foo). Do the length() ones first. - - for my $ioparam ( - grep $_->{is_ansi}, - ( - grep( $_->{is_length}, @{$ioparams->{kids}} ), - grep(! $_->{is_length}, @{$ioparams->{kids}} ), - ) - ) + # declared with a type in the signature (rather than in INPUT). - { + for my $ioparam (grep $_->{is_ansi}, @{$ioparams->{kids}}) { $ioparam->as_input_code($pxs, $xsub, $xbody); } @@ -4959,10 +5066,16 @@ sub parse { $s = 'FALSE' if $s eq '0'; $s = uc($s); - $self->death("Error: FALLBACK: TRUE/FALSE/UNDEF") + $pxs->death("Error: FALLBACK: invalid value '$s' (should be TRUE/FALSE/UNDEF)") unless $s =~ /^(TRUE|FALSE|UNDEF)$/; $self->{value} = $s; + + # Only only FALLBACK allowed per package + + $pxs->Warn("Warning: duplicate FALLBACK: entry") + if exists $pxs->{map_package_to_fallback_string}{$pxs->{PACKAGE_name}}; + $pxs->{map_package_to_fallback_string}{$pxs->{PACKAGE_name}} = $s; 1; @@ -4992,8 +5105,8 @@ sub parse { unless length $ver; # check that the version number is of the form n.n - $pxs->death("Error: REQUIRE: expected a number, got '$ver'") - unless $ver =~ /^\d+(\.\d*)?/; + $pxs->death("Error: REQUIRE: expected a MMM(.NNN) number, got '$ver'") + unless $ver =~ /^\d+(\.\d*)?$/; my $got = $ExtUtils::ParseXS::VERSION; $pxs->death("Error: xsubpp $ver (or better) required--this is only $got.") @@ -5026,38 +5139,39 @@ sub parse { my $f = $self->{text}; my $is_cmd = $self->{is_cmd}; + my $key = $is_cmd ? 'INCLUDE_COMMAND' : 'INCLUDE'; if ($is_cmd) { $f = $self->QuoteArgs($f) if $^O eq 'VMS'; - $pxs->death("INCLUDE_COMMAND: command missing") + $pxs->death("Error: INCLUDE_COMMAND: command missing") unless length $f; - $pxs->death("INCLUDE_COMMAND: pipes are illegal") + $pxs->death("Error: INCLUDE_COMMAND: pipes are illegal") if $f =~ /^\s*\|/ or $f =~ /\|\s*$/; } else { - $pxs->death("INCLUDE: filename missing") + $pxs->death("Error: INCLUDE: filename missing") unless length $f; - $pxs->death("INCLUDE: output pipe is illegal") + $pxs->death("Error: INCLUDE: output pipe is illegal") if $f =~ /^\s*\|/; # simple minded recursion detector - $pxs->death("INCLUDE loop detected") + $pxs->death("Error: INCLUDE: loop detected") if $pxs->{IncludedFiles}{$f}; ++$pxs->{IncludedFiles}->{$f} unless $f =~ /\|\s*$/; if ($f =~ /\|\s*$/ && $f =~ /^\s*perl\s/) { - $pxs->Warn( - "The INCLUDE directive with a command is discouraged." - . " Use INCLUDE_COMMAND instead! In particular using 'perl'" - . " in an 'INCLUDE: ... |' directive is not guaranteed to pick" - . " up the correct perl. The INCLUDE_COMMAND directive allows" - . " the use of \$^X as the currently running perl, see" - . " 'perldoc perlxs' for details." - ); + $pxs->WarnHint( + "Note: the INCLUDE directive with a command is discouraged", + <<'HINT'); +Use INCLUDE_COMMAND instead! In particular, using 'perl' in an +'INCLUDE: ... |' directive is not guaranteed to pick up the correct perl. +The INCLUDE_COMMAND directive allows the use of $^X as the currently +running perl, see 'perldoc perlxs' for details. +HINT } } @@ -5084,11 +5198,11 @@ sub parse { open ($pxs->{in_fh}, "-|", $f) or $pxs->death( - "Cannot run command '$f' to include its output: $!"); + "Error: INCLUDE_COMMAND: cannot run command '$f' to include its output: $!"); } else { open($pxs->{in_fh}, $f) - or $pxs->death("Cannot open '$f': $!"); + or $pxs->death("Error: INCLUDE: cannot open '$f': $!"); } $self->{old_filename} = $pxs->{in_filename}; @@ -5115,7 +5229,7 @@ sub parse { } $pxs->{lastline} = $_; - chomp $pxs->{lastline}; + chomp $pxs->{lastline} if defined $pxs->{lastline}; $pxs->{lastline_no} = $self->{line_no} = $.; # Parse included file @@ -5137,10 +5251,11 @@ sub parse { @$pxs{@save_keys} = @saved; - if ($isPipe and $? ) { - --$pxs->{lastline_no}; - print STDERR "Error reading from pipe '$self->{inc_filename}': $! in $pxs->{in_filename}, line $pxs->{lastline_no}\n" ; - exit 1; + if ($isPipe and $?) { + $pxs->death(sprintf + "Error: %s: got return code 0x%04x when reading from pipe '%s'", + $key, $?, $self->{inc_filename} + ); } 1; @@ -5244,7 +5359,7 @@ sub parse { # interpretation for backcomp, but warn. unless ($s =~ /^ ((ENABLE|DISABLE) D? ;?) \s* $ /xi) { - $pxs->death("Error: $keyword: ENABLE/DISABLE") + $pxs->death("Error: $keyword: invalid value '$s' (should be ENABLE/DISABLE)") } my ($value, $en_dis) = ($1, $2); $self->{enable} = $en_dis eq 'ENABLE' ? 1 : 0; @@ -5256,7 +5371,9 @@ sub parse { else { # SCOPE / VERSIONCHECK / EXPORT_XSUB_SYMBOLS $s =~ /^(ENABLE|DISABLE)\s*$/ - or $pxs->death("Error: $keyword: ENABLE/DISABLE"); + or $pxs->death( + "Error: $keyword: invalid value '$s' (should be ENABLE/DISABLE)" + ); $self->{enable} = $1 eq 'ENABLE' ? 1 : 0; } @@ -5509,12 +5626,12 @@ sub parse { $self->SUPER::parse($pxs); # set file/line_no, get lines, set text $xsub->{seen_INTERFACE} = 1; - my %map; - foreach (split /[\s,]+/, $self->{text}) { my $short = $_; $short =~ s/^$pxs->{PREFIX_pattern}//; - $map{$short} = $_; + $pxs->blurt("Error: duplicate INTERFACE name: '$short'") + if exists $xsub->{map_interface_name_short_to_original}{$short}; + $xsub->{map_interface_name_short_to_original}{$short} = $_; } @@ -5603,9 +5720,25 @@ sub parse { $self->SUPER::parse($pxs); # set file/line_no, get lines, set text my $s = $self->{text}; - while ($s =~ s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { - $self->{ops}{$1} = 1; - $xsub->{overload_name_seen}{$1} = 1; + + # Note that this doesn't check for the validity of an overload op + # name, to allow for forwards compatibility. + for my $op (split ' ', $s) { + if ($op !~ m{^ + ^ + ( [\w:"\\)+\-*/%<>.&|^!~{}=]+ ) + $ + }x) + + { + # Names with invalid characters are currently silently ignored + next; + } + + $self->{ops}{$op} = 1; + $pxs->Warn("Warning: duplicate OVERLOAD op name: '$op'") + if exists $xsub->{overload_name_seen}{$op}; + $xsub->{overload_name_seen}{$op} = 1; } # Mark the current package as being overloaded @@ -5720,9 +5853,21 @@ package ExtUtils::ParseXS::Node::codeblock; BEGIN { $build_subclass->(-parent => 'multiline', )}; +sub parse { + my __PACKAGE__ $self = shift; + my ExtUtils::ParseXS $pxs = shift; + my ExtUtils::ParseXS::Node::xsub $xsub = shift; + my ExtUtils::ParseXS::Node::xbody $xbody = shift; -# No parse() method: we just use the inherited Node::multiline's one + $self->SUPER::parse($pxs); # use multiline::parse() + # Text following the keyword is ignored rather than being treated + # as the first line of code. + my $line0 = shift @{$self->{lines}}; + $pxs->Warn("Warning: text after keyword ignored: '$line0'") + if defined $line0 && $line0 =~ /\S/; + return 1; +} # Emit the lines of code, skipping any initial blank lines, # and possibly wrapping in '#line' directives. @@ -5735,12 +5880,7 @@ sub as_code { my @lines = map "$_\n", @{$self->{lines}}; - my $n; - - # Ignore any text following the keyword on the same line. - # XXX this quietly ignores any such text - really it should - # warn, but not yet for backwards compatibility. - $n++, shift @lines if @lines; + my $n = 1; # strip leading blank lines $n++, shift @lines while @lines && $lines[0] !~ /\S/; @@ -6109,10 +6249,6 @@ sub parse { my $line = $self->{line}; # line of text to be processed ExtUtils::ParseXS::Utilities::trim_whitespace($line); - # XXX this skip doesn't make sense - we've already confirmed - # line has non-whitespace with the /\S/; so we just skip if the - # line is "0" ? - return unless $line; my $orig = $line; # keep full line for error messages @@ -6201,7 +6337,7 @@ sub parse { } $pxs->blurt("Error: cannot parse ALIAS definitions from '$orig'") - if $line; + if $line =~ /\S/; 1; } @@ -6295,7 +6431,11 @@ sub parse { # normal typemap), such as 'int foo = ($type)SvIV($arg)' my $var_init = ''; my $init_op; - ($init_op, $var_init) = ($1, $2) if $line =~ s/\s* ([=;+]) \s* (.*) $//xs; + if ($line =~ s/\s* ([=;+]) \s* (.*) $//xs) { + ($init_op, $var_init) = ($1, $2); + $pxs->death("Error: missing '$init_op' initialiser value") + unless $var_init =~ /\S/ && $var_init !~ /^\s*;\s*$/; + } $line =~ s/\s+/ /g; @@ -6530,8 +6670,13 @@ sub parse { $self->{do_setmagic} = $xbody->{OUTPUT_SETMAGIC_state}; $self->{is_setmagic} = 0; - if ($line =~ /^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { - $xbody->{OUTPUT_SETMAGIC_state} = ($1 eq "ENABLE" ? 1 : 0); + if ($line =~ /^\s*SETMAGIC\s*:\s*(.*?)\s*$/) { + my $arg = $1; + unless ($arg =~ /^(ENABLE|DISABLE)$/) { + $pxs->blurt("Error: SETMAGIC: invalid value '$arg' (should be ENABLE/DISABLE)"); + return; + } + $xbody->{OUTPUT_SETMAGIC_state} = ($arg eq "ENABLE" ? 1 : 0); $self->{do_setmagic} = $xbody->{OUTPUT_SETMAGIC_state}; $self->{is_setmagic} = 1; return; diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm index 3f843ade4b24..f013c28f74d9 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm @@ -22,6 +22,7 @@ our (@ISA, @EXPORT_OK); current_line_number blurt death + deathHint check_conditional_preprocessor_statements escape_file_for_line_directive report_typemap_failure @@ -417,11 +418,21 @@ is called, then instead it will die() with that message. This is a more obscure twin to C, which does the same as C, but afterwards, outputs any lines contained in the C<$hints> string, with -each line wrapped in parentheses. For example: +the paragraph wrapped in parentheses. For example: $self->WarnHint(@messages, "Have you set the foo switch?\nSee the manual for further info"); + +=item C<< $self->deathHint(@messages, $hints) >> + +This is a more obscure twin to C, which does the same as C, +but afterwards, outputs any lines contained in the C<$hints> string, with +the paragraph wrapped in parentheses. For example: + + $self->deathHint(@messages, + "Have you set the foo switch?\nSee the manual for further info"); + =back =cut @@ -450,7 +461,10 @@ sub _MsgHint { my $warn_line_number = $self->current_line_number(); my $ret = join("",@_) . " in $self->{in_filename}, line $warn_line_number\n"; if ($hint) { - $ret .= " ($_)\n" for split /\n/, $hint; + my @lines = map " $_", split /\n/, $hint; + $lines[0] =~ s/^ /(/; + $lines[-1] .= ')'; + $ret .= " $_\n" for @lines; } return $ret; } @@ -464,12 +478,11 @@ sub blurt { $self->{error_count}++ } - # see L above -sub death { +sub deathHint { my ExtUtils::ParseXS $self = $_[0]; - my $message = _MsgHint(@_,""); + my $message = _MsgHint(@_); if ($self->{config_die_on_error}) { die $message; } else { @@ -479,6 +492,14 @@ sub death { } +# see L above + +sub death { + deathHint(@_, undef); +} + + + =head2 C =over 4 diff --git a/dist/ExtUtils-ParseXS/lib/perlxs.pod b/dist/ExtUtils-ParseXS/lib/perlxs.pod index 6e08c2db4e83..51e78503cb9c 100644 --- a/dist/ExtUtils-ParseXS/lib/perlxs.pod +++ b/dist/ExtUtils-ParseXS/lib/perlxs.pod @@ -1922,13 +1922,13 @@ use C to individually override specific C, C, or C entries in the system typemap. In general, typemap changes affect any subsequent XSUBs within the file, until further updates. -Note however that, due to a quirk in parsing, it is possible for a -C block which comes I an XSUB to affect any -entries used by that XSUB, as if the block had appeared just before the -XSUB. If all such typemap blocks are placed near the start of an XS file, -then this won't be an issue. Indeed, it can only be a possible issue if -you want typemap meanings to change during the course of an XS file (which -is rare). +Note however that, due to a quirk in parsing, it is possible in F +prior to 3.61 for a C block which comes I an +XSUB to affect any entries used by that XSUB, as if the block had appeared +just before the XSUB. If all such typemap blocks are placed near the start +of an XS file, then this won't be an issue. Indeed, it can only be a +possible issue if you want typemap meanings to change during the course of +an XS file (which is rare). The C keyword syntax is intended to mimic Perl's "heredoc" syntax, and the keyword must be followed by one of these three forms: diff --git a/dist/ExtUtils-ParseXS/t/000-version.t b/dist/ExtUtils-ParseXS/t/000-version.t new file mode 100644 index 000000000000..d218625792d7 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/000-version.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl +# +# Test that ExtUtils::ParseXS can load, and that its version +# matches that in perlxs.pod. + +use strict; +use warnings; +use Test::More; +use File::Spec; +use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib'); + +require_ok( 'ExtUtils::ParseXS' ); + +{ + 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=~/\QThis document covers features supported by F \E(\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"); +} + +done_testing; diff --git a/dist/ExtUtils-ParseXS/t/001-basic.t b/dist/ExtUtils-ParseXS/t/001-basic.t deleted file mode 100644 index d904a95a68b9..000000000000 --- a/dist/ExtUtils-ParseXS/t/001-basic.t +++ /dev/null @@ -1,5906 +0,0 @@ -#!/usr/bin/perl - -use strict; -use Test::More; -use Config; -use DynaLoader; -use ExtUtils::CBuilder; -use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib'); -use PrimitiveCapture; - -my ($source_file, $obj_file, $lib_file); - -require_ok( 'ExtUtils::ParseXS' ); - -# Borrow the useful heredoc quoting/indenting function. -*Q = \&ExtUtils::ParseXS::Q; - - -{ - # Minimal tie package to capture output to a filehandle - package Capture; - sub TIEHANDLE { bless {} } - sub PRINT { shift->{buf} .= join '', @_ } - sub PRINTF { my $obj = shift; my $fmt = shift; - $obj->{buf} .= sprintf $fmt, @_ } - sub content { shift->{buf} } -} - -chdir('t') if -d 't'; -push @INC, '.'; - -package ExtUtils::ParseXS; -our $DIE_ON_ERROR = 1; -our $AUTHOR_WARNINGS = 1; -package main; - -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 -# refuse to load relative paths. The path that DynaLoader uses to load the -# .so or .bundle file is based on the @INC path that the library is loaded -# from. The XSTest module we're using for testing is in the current directory, -# so we need an absolute path in @INC rather than '.'. Just convert all of the -# paths to absolute for simplicity. -@INC = map { File::Spec->rel2abs($_) } @INC; - - - -######################### - -# test_many(): test a list of XSUB bodies with a common XS preamble. -# $prefix is the prefix of the XSUB's name, in order to be able to extract -# out the C function definition. Typically the generated C subs look like: -# -# XS_EXTERNAL(XS_Foo_foo) -# { -# ... -# } -# So setting prefix to 'XS_Foo' will match any fn declared in the Foo -# package, while 'boot_Foo' will extract the boot fn. -# -# For each body, a series of regexes is matched against the STDOUT or -# STDERR produced. -# -# $test_fns is an array ref, where each element is an array ref consisting -# of: -# -# [ -# "common prefix for test descriptions", -# [ ... lines to be ... -# ... used as ... -# ... XSUB body... -# ], -# [ check_stderr, expect_nomatch, qr/expected/, "test description"], -# [ ... and more tests ..] -# .... -# ] -# -# where: -# check_stderr: boolean: test STDERR against regex rather than STDOUT -# expect_nomatch: boolean: pass if the regex *doesn't* match - -sub test_many { - my ($preamble, $prefix, $test_fns) = @_; - for my $test_fn (@$test_fns) { - my ($desc_prefix, $xsub_lines, @tests) = @$test_fn; - - my $text = $preamble; - for (@$xsub_lines) { - $text .= $_; - $text .= "\n" unless /\n\z/; - } - - tie *FH, 'Capture'; - my $pxs = ExtUtils::ParseXS->new; - my $err; - my $stderr = PrimitiveCapture::capture_stderr(sub { - eval { - $pxs->process_file( filename => \$text, output => \*FH); - }; - $err = $@; - }); - if (defined $err and length $err) { - $stderr = "" unless defined $stderr; - $stderr = $err . $stderr; - } - - my $out = tied(*FH)->content; - untie *FH; - - # trim the output to just the function in question to make - # test diagnostics smaller. - if (defined($prefix) and !length($err) and $out =~ /\S/) { - $out =~ s/\A.*? (^\w+\(${prefix} .*? ^}).*\z/$1/xms - or do { - # print STDERR $out; - die "$desc_prefix: couldn't trim output to only function starting '$prefix'\n"; - } - } - - my $err_tested; - for my $test (@tests) { - my ($is_err, $exp_nomatch, $qr, $desc) = @$test; - $desc = "$desc_prefix: $desc" if length $desc_prefix; - my $str; - if ($is_err) { - $err_tested = 1; - $str = $stderr; - } - else { - $str = $out; - } - if ($exp_nomatch) { - unlike $str, $qr, $desc; - } - else { - like $str, $qr, $desc; - } - } - # if there were no tests that expect an error, test that there - # were no errors - if (!$err_tested) { - is $stderr, undef, "$desc_prefix: no errors expected"; - } - } -} - -######################### - - -{ # first block: try without linenumbers -my $pxs = ExtUtils::ParseXS->new; -# Try sending to filehandle -tie *FH, 'Capture'; -$pxs->process_file( filename => 'XSTest.xs', output => \*FH, prototypes => 1 ); -like tied(*FH)->content, '/is_even/', "Test that output contains some text"; - -$source_file = 'XSTest.c'; - -# Try sending to file -$pxs->process_file(filename => 'XSTest.xs', output => $source_file, prototypes => 0); -ok -e $source_file, "Create an output file"; - -my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE}; -my $b = ExtUtils::CBuilder->new(quiet => $quiet); - -SKIP: { - skip "no compiler available", 2 - if ! $b->have_compiler; - $obj_file = $b->compile( source => $source_file ); - ok $obj_file, "ExtUtils::CBuilder::compile() returned true value"; - ok -e $obj_file, "Make sure $obj_file exists"; -} - -SKIP: { - skip "no dynamic loading", 5 - if !$b->have_compiler || !$Config{usedl}; - my $module = 'XSTest'; - $lib_file = $b->link( objects => $obj_file, module_name => $module ); - ok $lib_file, "ExtUtils::CBuilder::link() returned true value"; - ok -e $lib_file, "Make sure $lib_file exists"; - - eval {require XSTest}; - is $@, '', "No error message recorded, as expected"; - ok XSTest::is_even(8), - "Function created thru XS returned expected true value"; - ok !XSTest::is_even(9), - "Function created thru XS returned expected false value"; - - # Win32 needs to close the DLL before it can unlink it, but unfortunately - # dl_unload_file was missing on Win32 prior to perl change #24679! - if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) { - for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) { - if ($DynaLoader::dl_modules[$i] eq $module) { - DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]); - last; - } - } - } -} - -my $seen = 0; -open my $IN, '<', $source_file - or die "Unable to open $source_file: $!"; -while (my $l = <$IN>) { - $seen++ if $l =~ m/#line\s1\s/; -} -is( $seen, 1, "Line numbers created in output file, as intended" ); -{ - #rewind .c file and regexp it to look for code generation problems - 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 -.+? -#line \d+\Q "XSTest.c" - ST(0) = boolSV(RETVAL); - } - XSRETURN(1); -} -\E|s; - like($filecontents, $good_T_BOOL_re, "T_BOOL doesn\'t have an extra sv_newmortal or sv_2mortal"); - - my $good_T_BOOL_2_re = -qr|\QXS_EUPXS(XS_XSTest_T_BOOL_2)\E -.+? -#line \d+\Q "XSTest.c" - sv_setsv(ST(0), boolSV(in)); - SvSETMAGIC(ST(0)); - } - XSRETURN(1); -} -\E|s; - like($filecontents, $good_T_BOOL_2_re, 'T_BOOL_2 doesn\'t have an extra sv_newmortal or sv_2mortal'); - my $good_T_BOOL_OUT_re = -qr|\QXS_EUPXS(XS_XSTest_T_BOOL_OUT)\E -.+? -#line \d+\Q "XSTest.c" - sv_setsv(ST(0), boolSV(out)); - SvSETMAGIC(ST(0)); - } - XSRETURN_EMPTY; -} -\E|s; - like($filecontents, $good_T_BOOL_OUT_re, 'T_BOOL_OUT doesn\'t have an extra sv_newmortal or sv_2mortal'); - -} -close $IN or die "Unable to close $source_file: $!"; - -unless ($ENV{PERL_NO_CLEANUP}) { - for ( $obj_file, $lib_file, $source_file) { - next unless defined $_; - 1 while unlink $_; - } -} -} - -##################################################################### - -{ # second block: try with linenumbers -my $pxs = ExtUtils::ParseXS->new; -# Try sending to filehandle -tie *FH, 'Capture'; -$pxs->process_file( - filename => 'XSTest.xs', - output => \*FH, - prototypes => 1, - linenumbers => 0, -); -like tied(*FH)->content, '/is_even/', "Test that output contains some text"; - -$source_file = 'XSTest.c'; - -# Try sending to file -$pxs->process_file( - filename => 'XSTest.xs', - output => $source_file, - prototypes => 0, - linenumbers => 0, -); -ok -e $source_file, "Create an output file"; - - -my $seen = 0; -open my $IN, '<', $source_file - or die "Unable to open $source_file: $!"; -while (my $l = <$IN>) { - $seen++ if $l =~ m/#line\s1\s/; -} -close $IN or die "Unable to close $source_file: $!"; -is( $seen, 0, "No linenumbers created in output file, as intended" ); - -unless ($ENV{PERL_NO_CLEANUP}) { - for ( $obj_file, $lib_file, $source_file) { - next unless defined $_; - 1 while unlink $_; - } -} -} -##################################################################### - -{ # third block: broken typemap -my $pxs = ExtUtils::ParseXS->new; -tie *FH, 'Capture'; -my $stderr = PrimitiveCapture::capture_stderr(sub { - $pxs->process_file(filename => 'XSBroken.xs', output => \*FH); -}); -like $stderr, '/Error: no INPUT definition/', "Exercise typemap error"; -} -##################################################################### - -{ # fourth block: https://github.com/Perl/perl5/issues/19661 - my $pxs = ExtUtils::ParseXS->new; - tie *FH, 'Capture'; - my ($stderr, $filename); - { - $filename = 'XSFalsePositive.xs'; - $stderr = PrimitiveCapture::capture_stderr(sub { - $pxs->process_file(filename => $filename, output => \*FH, prototypes => 1); - }); - { - 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); - }); - { - 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, 'Capture'; - 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, 'Capture'; - my $erred; - my $stderr = PrimitiveCapture::capture_stderr(sub { - eval { - $pxs->process_file( - filename => 'XSAlias.xs', - output => \*FH, - prototypes => 1); - }; - $erred = 1 if $@; - print STDERR "got eval err [$@]\n" if $@; - }); - die $stderr if $erred; # don't hide stderr if code errors out - - 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" - . "Warning: aliases 'do' and 'xunx', 'do' have identical values" - . " of 0 - the base function in XSAlias.xs, line 14\n" - . "Warning: aliases 'xunx2' and 'do', 'xunx' have" - . " identical values of 0 - the base function in XSAlias.xs, line 15\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, 'Capture'; - 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=~/\QThis document covers features supported by F \E(\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"); -} - -# Basic test of the death() method. -# Run some code which will trigger a call to death(). Check that we get -# the expected error message (and as an exception rather than being on -# stderr.) -{ - my $pxs = ExtUtils::ParseXS->new; - tie *FH, 'Capture'; - my $exception; - my $stderr = PrimitiveCapture::capture_stderr(sub { - eval { - $pxs->process_file( - filename => "XSNoMap.xs", - output => \*FH, - ); - 1; - } or $exception = $@; - }); - is($stderr, undef, "should fail to parse"); - like($exception, qr/Error: Unterminated TYPEMAP section/, - "check we throw rather than trying to deref '2'"); -} - - -{ - # Basic test of using a string ref as the input file - - my $pxs = ExtUtils::ParseXS->new; - tie *FH, 'Capture'; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |void f(int a) - | CODE: - | mycode; -EOF - - $pxs->process_file( filename => \$text, output => \*FH); - - my $out = tied(*FH)->content; - - # We should have got some content, and the generated '#line' lines - # should be sensible rather than '#line 1 SCALAR(0x...)'. - like($out, qr/XS_Foo_f/, "string ref: fn name"); - like($out, qr/#line \d+ "\(input\)"/, "string ref input #line"); - like($out, qr/#line \d+ "\(output\)"/, "string ref output #line"); -} - - -{ - # Test [=+;] on INPUT lines (including embedded double quotes - # within expression which get evalled) - - my $pxs = ExtUtils::ParseXS->new; - tie *FH, 'Capture'; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |void f(mymarker1, a, b, c, d) - | int mymarker1 - | int a = ($var"$var\"$type); - | int b ; blah($var"$var\"$type); - | int c + blurg($var"$var\"$type); - | int d - | CODE: - | mymarker2; -EOF - - $pxs->process_file( filename => \$text, output => \*FH); - - # Those INPUT lines should have produced something like: - # - # int mymarker1 = (int)SvIV(ST(0)); - # int a = (a"a\"int); - # int b; - # int c = (int)SvIV(ST(3)) - # int d = (int)SvIV(ST(4)) - # blah(b"b\"int); - # blurg(c"c\"int); - # mymarker2; - - my $out = tied(*FH)->content; - - # trim the output to just the function in question to make - # test diagnostics smaller. - $out =~ s/\A .*? (int \s+ mymarker1 .*? mymarker2 ) .* \z/$1/xms - or die "couldn't trim output"; - - like($out, qr/^ \s+ int \s+ a\ =\ \Q(a"a"int);\E $/xm, - "INPUT '=' expands custom typemap"); - - like($out, qr/^ \s+ int \s+ b;$/xm, - "INPUT ';' suppresses typemap"); - - like($out, qr/^ \s+ int \s+ c\ =\ \Q(int)SvIV(ST(3))\E $/xm, - "INPUT '+' expands standard typemap"); - - like($out, - qr/^ \s+ int \s+ d\ = .*? blah\Q(b"b"int)\E .*? blurg\Q(c"c"int)\E .*? mymarker2/xms, - "INPUT '+' and ';' append expanded code"); -} - - -{ - # Check that function pointer types are supported - - my $pxs = ExtUtils::ParseXS->new; - tie *FH, 'Capture'; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |TYPEMAP: <process_file( filename => \$text, output => \*FH); - - my $out = tied(*FH)->content; - - # trim the output to just the function in question to make - # test diagnostics smaller. - $out =~ s/\A .*? (int \s+ mymarker1 .*? XSRETURN ) .* \z/$1/xms - or die "couldn't trim output"; - - # remove all spaces for easier matching - my $sout = $out; - $sout =~ s/[ \t]+//g; - - like($sout, - qr/\Qint(*fn_ptr)(char*,long)=(int(*)(char*,long))INT2PTR(SvIV(ST(1)))/, - "function pointer declared okay"); -} - -{ - # Check that default expressions are template-expanded. - # Whether this is sensible or not, Dynaloader and other distributions - # rely on it - - my $pxs = ExtUtils::ParseXS->new; - tie *FH, 'Capture'; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |void foo(int mymarker1, char *pkg = "$Package") - | CODE: - | mymarker2; -EOF - - $pxs->process_file( filename => \$text, output => \*FH); - - my $out = tied(*FH)->content; - - # trim the output to just the function in question to make - # test diagnostics smaller. - $out =~ s/\A .*? (int \s+ mymarker1 .*? mymarker2 ) .* \z/$1/xms - or die "couldn't trim output"; - - # remove all spaces for easier matching - my $sout = $out; - $sout =~ s/[ \t]+//g; - - like($sout, qr/pkg.*=.*"Foo"/, "default expression expanded"); -} - -{ - # Test 'alien' INPUT parameters: ones which are declared in an INPUT - # section but don't appear in the XSUB's signature. This ought to be - # a compile error, but people rely on it to declare and initialise - # variables which ought to be in a PREINIT or CODE section. - - my $pxs = ExtUtils::ParseXS->new; - tie *FH, 'Capture'; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |void foo(mymarker1) - | int mymarker1 - | long alien1 - | int alien2 = 123; - | CODE: - | mymarker2; -EOF - - $pxs->process_file( filename => \$text, output => \*FH); - - my $out = tied(*FH)->content; - - # trim the output to just the function in question to make - # test diagnostics smaller. - $out =~ s/\A .*? (int \s+ mymarker1 .*? mymarker2 ) .* \z/$1/xms - or die "couldn't trim output"; - - # remove all spaces for easier matching - my $sout = $out; - $sout =~ s/[ \t]+//g; - - like($sout, qr/longalien1;\nintalien2=123;/, "alien INPUT parameters"); -} - -{ - # Test for 'No INPUT definition' error, particularly that the - # type is output correctly in the error message. - - my $pxs = ExtUtils::ParseXS->new; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |TYPEMAP: <process_file( filename => \$text, output => \*FH); - }); - - like($stderr, qr/Error: no INPUT definition for type 'Foo::Bar'/, - "No INPUT definition"); -} - -{ - # Test for default arg mixed with initialisers - - my $pxs = ExtUtils::ParseXS->new; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |void foo(mymarker1, aaa = 111, bbb = 222, ccc = 333, ddd = NO_INIT, eee = NO_INIT, fff = NO_INIT) - | int mymarker1 - | int aaa = 777; - | int bbb + 888; - | int ccc ; 999; - | int ddd = AAA; - | int eee + BBB; - | int fff ; CCC; - | CODE: - | mymarker2 -EOF - - tie *FH, 'Capture'; - $pxs->process_file( filename => \$text, output => \*FH); - - my $out = tied(*FH)->content; - - # trim the output to just the function in question to make - # test diagnostics smaller. - $out =~ s/\A .*? (int \s+ mymarker1 .*? mymarker2 ) .* \z/$1/xms - or die "couldn't trim output"; - - # remove all spaces for easier matching - my $sout = $out; - $sout =~ s/[ \t]+//g; - - like($sout, qr/if\(items<3\)\nbbb=222;\nelse\{\nbbb=.*ST\(2\)\)\n;\n\}\n/, - "default with +init"); - - like($sout, qr/\Qif(items>=6){\E\n\Qeee=(int)SvIV(ST(5))\E\n;\n\}/, - "NO_INIT default with +init"); - - { - local $TODO = "default is lost in presence of initialiser"; - - like($sout, qr/if\(items<2\)\naaa=111;\nelse\{\naaa=777;\n\}\n/, - "default with =init"); - - like($sout, qr/if\(items<4\)\nccc=333;\n999;\n/, - "default with ;init"); - - like($sout, qr/if\(items>=5\)\{\nddd=AAA;\n\}/, - "NO_INIT default with =init"); - unlike($sout, qr/^intddd=AAA;\n/m, - "NO_INIT default with =init no stray"); - - } - - - like($sout, qr/^$/m, - "default with +init deferred expression"); - like($sout, qr/^888;$/m, - "default with +init deferred expression"); - like($sout, qr/^999;$/m, - "default with ;init deferred expression"); - like($sout, qr/^BBB;$/m, - "NO_INIT default with +init deferred expression"); - like($sout, qr/^CCC;$/m, - "NO_INIT default with ;init deferred expression"); - -} - -{ - # C++ methods: check that a sub name including a class auto-generates - # a THIS or CLASS parameter - - my $pxs = ExtUtils::ParseXS->new; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |TYPEMAP: <process_file( filename => \$text, output => \*FH); - - my $out = tied(*FH)->content; - - # trim the output to just the function in question to make - # test diagnostics smaller. - $out =~ s/\A .*? (int \s+ mymarker1 .*? mymarker2 ) .* \z/$1/xms - or die "couldn't trim output"; - - like($out, qr/^\s*\Qchar *\E\s+CLASS = \Q(char *)SvPV_nolen(ST(0))\E$/m, - "CLASS auto-generated"); - like($out, qr/^\s*\QX__Y *\E\s+THIS = \Qmy_xy(ST(0))\E$/m, - "THIS auto-generated"); - -} - -{ - # Test for 'length(foo)' not legal in INPUT section - - my $pxs = ExtUtils::ParseXS->new; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |void foo(s) - | char *s - | int length(s) -EOF - - tie *FH, 'Capture'; - my $stderr = PrimitiveCapture::capture_stderr(sub { - $pxs->process_file( filename => \$text, output => \*FH); - }); - - like($stderr, qr/./, - "No length() in INPUT section"); -} - -{ - # Test for initialisers with unknown variable type. - # This previously died. - - my $pxs = ExtUtils::ParseXS->new; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |void foo(a, b, c) - | UnknownType a = NO_INIT - | UnknownType b = bar(); - | UnknownType c = baz($arg); -EOF - - tie *FH, 'Capture'; - my $stderr = PrimitiveCapture::capture_stderr(sub { - $pxs->process_file( filename => \$text, output => \*FH); - }); - - is($stderr, undef, "Unknown type with initialiser: no errors"); -} - -{ - # Test for "duplicate definition of argument" errors - - my $pxs = ExtUtils::ParseXS->new; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |void foo(a, b, int c) - | int a; - | int a; - | int b; - | int b; - | int c; - | int alien; - | int alien; -EOF - - tie *FH, 'Capture'; - my $stderr = PrimitiveCapture::capture_stderr(sub { - $pxs->process_file( filename => \$text, output => \*FH); - }); - - for my $var (qw(a b c alien)) { - my $count = () = - $stderr =~ /duplicate definition of parameter '$var'/g; - is($count, 1, "One dup error for \"$var\""); - } -} - -{ - # Basic check of an OUT parameter where the type is specified either - # in the signature or in an INPUT line - - my $pxs = ExtUtils::ParseXS->new; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |int - |f(marker1, OUT a, OUT int b) - | int mymarker1 - | int a - | CODE: - | mymarker2 - | -EOF - - tie *FH, 'Capture'; - $pxs->process_file( filename => \$text, output => \*FH); - - my $out = tied(*FH)->content; - - # trim the output to just the function in question to make - # test diagnostics smaller. - $out =~ s/\A .*? (int \s+ mymarker1 .*? mymarker2 ) .* \z/$1/xms - or die "couldn't trim output"; - - like($out, qr/^\s+int\s+a;\s*$/m, "OUT a"); - like($out, qr/^\s+int\s+b;\s*$/m, "OUT b"); - -} - -{ - # Basic check of a "usage: ..." string. - # In particular, it should strip away type and IN/OUT class etc. - # Also, some distros include a test of their usage strings which - # are sensitive to variations in white space, so this test - # confirms that the exact white space is preserved, especially - # with regards to space (or not) around the '=' of a default value. - - my $pxs = ExtUtils::ParseXS->new; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |int - |foo( a , char * b , OUT int c , OUTLIST int d , \ - | IN_OUT char * * e = 1 + 2 , long length(e) , \ - | char* f="abc" , g = 0 , ... ) -EOF - - tie *FH, 'Capture'; - $pxs->process_file( filename => \$text, output => \*FH); - - my $out = tied(*FH)->content; - - my $ok = $out =~ /croak_xs_usage\(cv,\s*(".*")\);\s*$/m; - my $str = $ok ? $1 : ''; - ok $ok, "extract usage string"; - is $str, q("a, b, c, e= 1 + 2, f=\"abc\", g = 0, ..."), - "matched usage string"; -} - -{ - # Test for parameter parsing errors, including the effects of the - # -noargtype and -noinout switches - - my $pxs = ExtUtils::ParseXS->new; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |void - |foo(char* a, length(a) = 0, IN c, +++) -EOF - - tie *FH, 'Capture'; - my $stderr = PrimitiveCapture::capture_stderr(sub { - eval { - $pxs->process_file( filename => \$text, output => \*FH, - argtypes => 0, inout => 0); - } - }); - - like $stderr, qr{\QError: parameter type not allowed under -noargtypes}, - "no type under -noargtypes"; - like $stderr, qr{\QError: length() pseudo-parameter not allowed under -noargtypes}, - "no length under -noargtypes"; - like $stderr, qr{\QError: parameter IN/OUT modifier not allowed under -noinout}, - "no IN/OUT under -noinout"; - like $stderr, qr{\QError: unparseable XSUB parameter: '+++'}, - "unparseable parameter"; -} - -{ - # Test for ellipis in the signature. - - my $pxs = ExtUtils::ParseXS->new; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |void - |foo(int mymarker1, char *b = "...", int c = 0, ...) - | POSTCALL: - | mymarker2; -EOF - - tie *FH, 'Capture'; - $pxs->process_file( filename => \$text, output => \*FH); - - my $out = tied(*FH)->content; - - # trim the output to just the function in question to make - # test diagnostics smaller. - $out =~ s/\A .*? (int \s+ mymarker1 .*? mymarker2 ) .* \z/$1/xms - or die "couldn't trim output"; - - like $out, qr/\Qb = "..."/, "ellipsis: b has correct default value"; - like $out, qr/b = .*SvPV/, "ellipsis: b has correct non-default value"; - like $out, qr/\Qc = 0/, "ellipsis: c has correct default value"; - like $out, qr/c = .*SvIV/, "ellipsis: c has correct non-default value"; - like $out, qr/\Qfoo(mymarker1, b, c)/, "ellipsis: wrapped function args"; -} - -{ - # Test for bad ellipsis - - my $pxs = ExtUtils::ParseXS->new; - my $text = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |void - |foo(a, ..., b) -EOF - - tie *FH, 'Capture'; - my $stderr = PrimitiveCapture::capture_stderr(sub { - eval { - $pxs->process_file( filename => \$text, output => \*FH); - } - }); - - like $stderr, qr{\QError: further XSUB parameter seen after ellipsis}, - "further XSUB parameter seen after ellipsis"; -} - -{ - # Test for C++ XSUB support: in particular, - # - an XSUB function including a class in its name implies C++ - # - implicit CLASS/THIS first arg - # - new and DESTROY methods handled specially - # - 'static' return type implies class method - # - 'const' can follow signature - # - - my $preamble = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |TYPEMAP: <fff(bbb)/, "autocall" ], - ], - - [ - "C++: ggg", - [ - 'static int', - 'X::Y::ggg(int ccc)', - ], - [ 0, 0, qr/usage\(cv,\s+"CLASS, ccc"\)/, "usage" ], - [ 0, 0, qr/char\s*\*\s*CLASS\b/, "var decl" ], - [ 0, 0, qr/\QX::Y::ggg(ccc)/, "autocall" ], - ], - - [ - "C++: hhh", - [ - 'int', - 'X::Y::hhh(int ddd) const', - ], - [ 0, 0, qr/usage\(cv,\s+"THIS, ddd"\)/, "usage" ], - [ 0, 0, qr/const X__Y\s*\*\s*THIS\s*=\s*my_in/, "var decl" ], - [ 0, 0, qr/\QTHIS->hhh(ddd)/, "autocall" ], - ], - - [ - "C++: only const", - [ - 'void', - 'foo() const', - ], - [ 1, 0, qr/\Qconst modifier only allowed on XSUBs which are C++ methods/, - "got expected err" ], - ], - - # autocall variants with const - - [ - "C++: static const", - [ Q(<<'EOF') ], - |static int - |X::Y::foo() const -EOF - [ 0, 0, qr/\QRETVAL = X::Y::foo()/, - "autocall doesn't have const" ], - ], - - [ - "C++: static new const", - [ Q(<<'EOF') ], - |static int - |X::Y::new() const -EOF - [ 0, 0, qr/\QRETVAL = X::Y()/, - "autocall doesn't have const" ], - ], - - [ - "C++: const", - [ Q(<<'EOF') ], - |int - |X::Y::foo() const -EOF - [ 0, 0, qr/\QRETVAL = THIS->foo()/, - "autocall doesn't have const" ], - ], - - [ - "C++: new const", - [ Q(<<'EOF') ], - |int - |X::Y::new() const -EOF - [ 0, 0, qr/\QRETVAL = new X::Y()/, - "autocall doesn't have const" ], - ], - - [ - "", - [ - 'int', - 'X::Y::f1(THIS, int i)', - ], - [ 1, 0, qr/\QError: duplicate definition of parameter 'THIS' /, - "C++: f1 dup THIS" ], - ], - - [ - "", - [ - 'int', - 'X::Y::f2(int THIS, int i)', - ], - [ 1, 0, qr/\QError: duplicate definition of parameter 'THIS' /, - "C++: f2 dup THIS" ], - ], - - [ - "", - [ - 'int', - 'X::Y::new(int CLASS, int i)', - ], - [ 1, 0, qr/\QError: duplicate definition of parameter 'CLASS' /, - "C++: new dup CLASS" ], - ], - - [ - "C++: f3", - [ - 'int', - 'X::Y::f3(int i)', - ' OUTPUT:', - ' THIS', - ], - [ 0, 0, qr/usage\(cv,\s+"THIS, i"\)/, "usage" ], - [ 0, 0, qr/X__Y\s*\*\s*THIS\s*=\s*my_in/, "var decl" ], - [ 0, 0, qr/\QTHIS->f3(i)/, "autocall" ], - [ 0, 0, qr/^\s*\Qmy_out(ST(0), THIS)/m, "set st0" ], - ], - - [ - # allow THIS's type to be overridden ... - "C++: f4: override THIS type", - [ - 'int', - 'X::Y::f4(int i)', - ' int THIS', - ], - [ 0, 0, qr/usage\(cv,\s+"THIS, i"\)/, "usage" ], - [ 0, 0, qr/int\s*THIS\s*=\s*\(int\)/, "var decl" ], - [ 0, 1, qr/X__Y\s*\*\s*THIS/, "no class var decl" ], - [ 0, 0, qr/\QTHIS->f4(i)/, "autocall" ], - ], - - [ - # ... but not multiple times - "C++: f5: dup override THIS type", - [ - 'int', - 'X::Y::f5(int i)', - ' int THIS', - ' long THIS', - ], - [ 1, 0, qr/\QError: duplicate definition of parameter 'THIS'/, - "dup err" ], - ], - - [ - # don't allow THIS in sig, with type - "C++: f6: sig THIS type", - [ - 'int', - 'X::Y::f6(int THIS)', - ], - [ 1, 0, qr/\QError: duplicate definition of parameter 'THIS'/, - "dup err" ], - ], - - [ - # don't allow THIS in sig, without type - "C++: f7: sig THIS no type", - [ - 'int', - 'X::Y::f7(THIS)', - ], - [ 1, 0, qr/\QError: duplicate definition of parameter 'THIS'/, - "dup err" ], - ], - - [ - # allow CLASS's type to be overridden ... - "C++: new: override CLASS type", - [ - 'int', - 'X::Y::new(int i)', - ' int CLASS', - ], - [ 0, 0, qr/usage\(cv,\s+"CLASS, i"\)/, "usage" ], - [ 0, 0, qr/int\s*CLASS\s*=\s*\(int\)/, "var decl" ], - [ 0, 1, qr/char\s*\*\s*CLASS/, "no char* var decl" ], - [ 0, 0, qr/\Qnew X::Y(i)/, "autocall" ], - ], - - [ - # ... but not multiple times - "C++: new dup override CLASS type", - [ - 'int', - 'X::Y::new(int i)', - ' int CLASS', - ' long CLASS', - ], - [ 1, 0, qr/\QError: duplicate definition of parameter 'CLASS'/, - "dup err" ], - ], - - [ - # don't allow CLASS in sig, with type - "C++: new sig CLASS type", - [ - 'int', - 'X::Y::new(int CLASS)', - ], - [ 1, 0, qr/\QError: duplicate definition of parameter 'CLASS'/, - "dup err" ], - ], - - [ - # don't allow CLASS in sig, without type - "C++: new sig CLASS no type", - [ - 'int', - 'X::Y::new(CLASS)', - ], - [ 1, 0, qr/\QError: duplicate definition of parameter 'CLASS'/, - "dup err" ], - ], - - [ - "C++: DESTROY", - [ - 'void', - 'X::Y::DESTROY()', - ], - [ 0, 0, qr/usage\(cv,\s+"THIS"\)/, "usage" ], - [ 0, 0, qr/X__Y\s*\*\s*THIS\s*=\s*my_in/, "var decl" ], - [ 0, 0, qr/delete\s+THIS;/, "autocall" ], - ] - ); - - test_many($preamble, 'XS_Foo_', \@test_fns); -} - - -{ - # Test return type declarations - - my $preamble = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | -EOF - - my @test_fns = ( - [ - "NO_OUTPUT", - [ Q(<<'EOF') ], - |NO_OUTPUT int - |foo() -EOF - [ 0, 0, qr/\QRETVAL = foo();/, "has autocall" ], - [ 0, 1, qr/\bTARG/, "no setting TARG" ], - [ 0, 1, qr/\QST(0)/, "no setting ST(0)" ], - ], - [ - "xsub decl on one line", - [ Q(<<'EOF') ], - | int foo(A, int B ) - | char *A -EOF - [ 0, 0, qr/^\s+char \*\s+A\s+=/m, "has A decl" ], - [ 0, 0, qr/^\s+int\s+B\s+=/m, "has B decl" ], - [ 0, 0, qr/\QRETVAL = foo(A, B);/, "has autocall" ], - ], - ); - - test_many($preamble, 'XS_Foo_', \@test_fns); -} - - -{ - # Test XSUB declarations declarations - # Generates errors which don't result in an XSUB being emitted, - # so use 'undef' in the test_many() call to not strip down output - - my $preamble = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | -EOF - - my @test_fns = ( - [ - "extern C", - [ Q(<<'EOF') ], - |extern "C" int - |foo() -EOF - [ 0, 0, qr/^extern "C"\nXS_EUPXS\(XS_Foo_foo\);/m, - "has extern decl" ], - ], - [ - "defn too short", - [ Q(<<'EOF') ], - |int -EOF - [ 1, 0, qr/Error: function definition too short 'int'/, "got err" ], - ], - [ - "defn not parseable 1", - [ Q(<<'EOF') ], - |int - |foo(aaa - | CODE: - | AAA -EOF - [ 1, 0, qr/\QError: cannot parse function definition from 'foo(aaa' in\E.*line 6/, - "got err" ], - ], - [ - "defn not parseable 2", - [ Q(<<'EOF') ], - |int - |fo o(aaa) -EOF - [ 1, 0, qr/\QError: cannot parse function definition from 'fo o(aaa)' in\E.*line 6/, - "got err" ], - ], - - # note that issuing this warning is somewhat controversial: - # see GH 19661. But while we continue to warn, test that we get a - # warning. - [ - "dup fn warning", - [ Q(<<'EOF') ], - |int - |foo(aaa) - | - |int - |foo(aaa) -EOF - [ 1, 0, qr/\QWarning: duplicate function definition 'foo' detected in\E.*line 9/, - "got warn" ], - ], - [ - "dup fn warning", - [ Q(<<'EOF') ], - |#if X - |int - |foo(aaa) - | - |#else - |int - |foo(aaa) - |#endif -EOF - [ 1, 1, qr/\QWarning: duplicate function definition/, - "no warning" ], - ], - ); - - test_many($preamble, undef, \@test_fns); -} - - -{ - # check that suitable "usage: " error strings are generated - - my $preamble = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | -EOF - - my @test_fns = ( - [ - "general usage", - [ - 'void', - 'foo(a, char *b, int length(b), int d = 999, ...)', - ' long a', - ], - [ 0, 0, qr/usage\(cv,\s+"a, b, d= 999, ..."\)/, "" ], - ] - ); - - test_many($preamble, 'XS_Foo_', \@test_fns); -} - -{ - # misc checks for length() pseudo-parameter - - my $preamble = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | -EOF - - my @test_fns = ( - [ - "length() basic", - [ Q(<<'EOF') ], - |void - |foo(char *s, int length(s)) -EOF - [ 0, 0, qr{^\s+STRLEN\s+STRLEN_length_of_s;}m, "decl STRLEN" ], - [ 0, 0, qr{^\s+int\s+XSauto_length_of_s;}m, "decl int" ], - - [ 0, 0, qr{^ \s+ \Qchar *\E \s+ - \Qs = (char *)SvPV(ST(0), STRLEN_length_of_s);}xm, - "decl s" ], - - [ 0, 0, qr{^\s+\QXSauto_length_of_s = STRLEN_length_of_s}m, - "assign" ], - - [ 0, 0, qr{^\s+\Qfoo(s, XSauto_length_of_s);}m, "autocall" ], - ], - [ - "length() default value", - [ Q(<<'EOF') ], - |void - |foo(char *s, length(s) = 0) -EOF - [ 1, 0, qr{\QError: default value not allowed on length() parameter 's'\E.*line 6}, - "got expected error" ], - ], - [ - "length() no matching var", - [ Q(<<'EOF') ], - |void - |foo(length(s)) -EOF - [ 1, 0, qr{\QError: length() on non-parameter 's'\E.*line 6}, - "got expected error" ], - ], - ); - - test_many($preamble, 'XS_Foo_', \@test_fns); -} - -{ - # check that args to an auto-called C function are correct - - my $preamble = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | -EOF - - my @test_fns = ( - [ - "autocall args normal", - [ - 'void', - 'foo( OUT int a, b , char * c , int length(c), OUTLIST int d, IN_OUTLIST int e)', - ' long &b', - ' int alien', - ], - [ 0, 0, qr/\Qfoo(&a, &b, c, XSauto_length_of_c, &d, &e)/, "" ], - ], - [ - "autocall args normal", - [ - 'void', - 'foo( OUT int a, b , char * c , size_t length(c) )', - ' long &b', - ' int alien', - ], - [ 0, 0, qr/\Qfoo(&a, &b, c, XSauto_length_of_c)/, "" ], - ], - - [ - "autocall args C_ARGS", - [ - 'void', - 'foo( int a, b , char * c )', - ' C_ARGS: a, b , bar, c? c : "boo!" ', - ' INPUT:', - ' long &b', - ], - [ 0, 0, qr/\Qfoo(a, b , bar, c? c : "boo!")/, "" ], - ], - - [ - "autocall args empty C_ARGS", - [ Q(<<'EOF') ], - |void - |foo(int a) - | C_ARGS: -EOF - [ 0, 0, qr/\Qfoo()/, "" ], - ], - - [ - # Whether this is sensible or not is another matter. - # For now, just check that it works as-is. - "autocall args C_ARGS multi-line", - [ - 'void', - 'foo( int a, b , char * c )', - ' C_ARGS: a,', - ' b , bar,', - ' c? c : "boo!"', - ' INPUT:', - ' long &b', - ], - [ 0, 0, qr/\(a,\n b , bar,\n\Q c? c : "boo!")/, - "" ], - ], - ); - - test_many($preamble, 'XS_Foo_', \@test_fns); -} - -{ - # Test OUTLIST etc - - my $preamble = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |TYPEMAP: < foo - | biz => Baz::baz -EOF - [ 0, 0, qr{"Foo::foo",.*\n.*= 1;}, - "has Foo::foo" ], - [ 0, 0, qr{"Foo::bar",.*\n.*= 2;}, - "has Foo::bar" ], - [ 0, 0, qr{"Baz::baz",.*\n.*= 3;}, - "has Baz::baz" ], - [ 0, 0, qr{"Foo::boz",.*\n.*= BOZ_VAL;}, - "has Foo::boz" ], - [ 0, 0, qr{"Foo::buz",.*\n.*= 1;}, - "has Foo::buz" ], - [ 0, 0, qr{"Foo::biz",.*\n.*= 3;}, - "has Foo::biz" ], - [ 0, 0, qr{\QCV * cv;}, "has cv declaration" ], - ], - - [ - "ALIAS with main as default of 0", - [ Q(<<'EOF') ], - |void - |foo() - | ALIAS: - | bar = 2 -EOF - [ 0, 0, qr{"Foo::foo",.*\n.*= 0;}, - "has Foo::foo" ], - [ 0, 0, qr{"Foo::bar",.*\n.*= 2;}, - "has Foo::bar" ], - ], - - [ - "ALIAS multi-perl-line, blank lines", - [ Q(<<'EOF') ], - |void - |foo() - | ALIAS: foo = 1 bar = 2 - | - | Baz::baz = 3 boz = BOZ_VAL - | buz => foo - | biz => Baz::baz - | - | -EOF - [ 0, 0, qr{"Foo::foo",.*\n.*= 1;}, - "has Foo::foo" ], - [ 0, 0, qr{"Foo::bar",.*\n.*= 2;}, - "has Foo::bar" ], - [ 0, 0, qr{"Baz::baz",.*\n.*= 3;}, - "has Baz::baz" ], - [ 0, 0, qr{"Foo::boz",.*\n.*= BOZ_VAL;}, - "has Foo::boz" ], - [ 0, 0, qr{"Foo::buz",.*\n.*= 1;}, - "has Foo::buz" ], - [ 0, 0, qr{"Foo::biz",.*\n.*= 3;}, - "has Foo::biz" ], - ], - - [ - "ALIAS no colon", - [ Q(<<'EOF') ], - |void - |foo() - | ALIAS: bar = X::Y -EOF - [ 1, 0, qr{\QError: in alias definition for 'bar' the value may not contain ':' unless it is symbolic.\E.*line 7}, - "got expected error" ], - ], - - [ - "ALIAS unknown alias", - [ Q(<<'EOF') ], - |void - |foo() - | ALIAS: Foo::bar => blurt -EOF - [ 1, 0, qr{\QError: unknown alias 'Foo::blurt' in symbolic definition for 'Foo::bar'\E.*line 7}, - "got expected error" ], - ], - - [ - "ALIAS warn duplicate", - [ Q(<<'EOF') ], - |void - |foo() - | ALIAS: bar = 1 - | bar = 1 -EOF - [ 1, 0, qr{\QWarning: ignoring duplicate alias 'bar'\E.*line 8}, - "got expected warning" ], - ], - [ - "ALIAS warn conflict duplicate", - [ Q(<<'EOF') ], - |void - |foo() - | ALIAS: bar = 1 - | bar = 2 -EOF - [ 1, 0, qr{\QWarning: conflicting duplicate alias 'bar'\E.*line 8}, - "got expected warning" ], - ], - - [ - "ALIAS warn identical values", - [ Q(<<'EOF') ], - |void - |foo() - | ALIAS: bar = 1 - | baz = 1 -EOF - [ 1, 0, qr{\QWarning: aliases 'baz' and 'bar' have identical values of 1\E.*line 8}, - "got expected warning" ], - ], - - [ - "ALIAS unparseable entry", - [ Q(<<'EOF') ], - |void - |foo() - | ALIAS: bar = -EOF - [ 1, 0, qr{\QError: cannot parse ALIAS definitions from 'bar ='\E.*line 7}, - "got expected error" ], - ], - ); - - test_many($preamble, 'boot_Foo', \@test_fns); -} - -{ - # Test ALIAS keyword - XSUB body - - my $preamble = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | -EOF - - my @test_fns = ( - [ - 'ALIAS with $ALIAS used in typemap entry', - [ Q(<<'EOF') ], - |void - |foo(AV *av) - | ALIAS: bar = 1 -EOF - [ 0, 0, qr{croak.*\n.*\QGvNAME(CvGV(cv))}, - "got alias variant of croak message" ], - ], - ); - - test_many($preamble, 'XS_Foo_', \@test_fns); -} - - -{ - # Test INTERFACE keyword - boot code - - my $preamble = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | -EOF - - my @test_fns = ( - [ - "INTERFACE basic boot", - [ Q(<<'EOF') ], - |void - |foo() - | INTERFACE: f1 f2 -EOF - [ 0, 0, qr{ \QnewXS_deffile("Foo::f1", XS_Foo_foo);\E\n - \s+\QXSINTERFACE_FUNC_SET(cv,f1);\E - }x, - "got f1 entries" ], - [ 0, 0, qr{ \QnewXS_deffile("Foo::f2", XS_Foo_foo);\E\n - \s+\QXSINTERFACE_FUNC_SET(cv,f2);\E - }x, - "got f2 entries" ], - [ 0, 0, qr{\QCV * cv;}, "has cv declaration" ], - ], - ); - - test_many($preamble, 'boot_Foo', \@test_fns); -} - -{ - # Test INTERFACE keyword - XSUB body - - my $preamble = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |TYPEMAP: < - | + - * / - | OVERLOAD: > < >= -EOF - [ 0, 0, qr{\Q"Foo::(*"}, "has Foo::(* method" ], - [ 0, 0, qr{\Q"Foo::(+"}, "has Foo::(+ method" ], - [ 0, 0, qr{\Q"Foo::(-"}, "has Foo::(- method" ], - [ 0, 0, qr{\Q"Foo::(/"}, "has Foo::(/ method" ], - [ 0, 0, qr{\Q"Foo::(<"}, "has Foo::(< method" ], - [ 0, 0, qr{\Q"Foo::(<=>"}, "has Foo::(<=> method" ], - [ 0, 0, qr{\Q"Foo::(>"}, "has Foo::(> method" ], - [ 0, 0, qr{\Q"Foo::(>="}, "has Foo::(>= method" ], - [ 0, 0, qr{\Q"Foo::(cmp"}, "has Foo::(cmp method" ], - ], - - ); - - test_many($preamble, 'boot_Foo', \@test_fns); -} - - -{ - # Test INIT: keyword - - my $preamble = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | -EOF - - my @test_fns = ( - [ - "INIT basic", - [ Q(<<'EOF') ], - |void - |foo(aaa, short bbb) - | int aaa - | INIT: - | XXX - | YYY - | CODE: - | ZZZ -EOF - [ 0, 0, qr{\bint\s+aaa}, "has aaa decl" ], - [ 0, 0, qr{\bshort\s+bbb}, "has bbb decl" ], - [ 0, 0, qr{^\s+XXX\n\s+YYY\n}m, "has XXX, YYY" ], - [ 0, 0, qr{^\s+ZZZ\n}m, "has ZZZ" ], - [ 0, 0, qr{aaa.*bbb.*XXX.*YYY.*ZZZ}s,"in sequence" ], - ], - - ); - - test_many($preamble, 'XS_Foo_', \@test_fns); -} - - -{ - # Test NOT_IMPLEMENTED_YET pseudo-keyword - - my $preamble = Q(<<'EOF'); - |MODULE = Foo PACKAGE = Foo - | - |PROTOTYPES: DISABLE - | - |TYPEMAP: <catdir(qw(t lib)) : 'lib'); + +# Private test utilities +use TestMany; + +require_ok( 'ExtUtils::ParseXS' ); + +# Borrow the useful heredoc quoting/indenting function. +*Q = \&ExtUtils::ParseXS::Q; + +chdir('t') if -d 't'; +push @INC, '.'; + +package ExtUtils::ParseXS; +our $DIE_ON_ERROR = 1; +our $AUTHOR_WARNINGS = 1; +package main; + +{ + # Basic test of using a string ref as the input file + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "using string ref as input file", + Q(<<'EOF'), + |void f(int a) + | CODE: + | mycode; +EOF + # We should have got some content, and the generated '#line' lines + # should be sensible rather than '#line 1 SCALAR(0x...)'. + [ 0, qr/XS_Foo_f/, "fn name" ], + [ 0, qr/#line \d+ "\(input\)"/, "input #line" ], + [ 0, qr/#line \d+ "\(output\)"/, "output #line" ], + ], + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +done_testing; diff --git a/dist/ExtUtils-ParseXS/t/002-parse-file-scope.t b/dist/ExtUtils-ParseXS/t/002-parse-file-scope.t new file mode 100644 index 000000000000..d63a9a18c155 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/002-parse-file-scope.t @@ -0,0 +1,505 @@ +#!/usr/bin/perl +# +# 002-parse-file-scope.t: +# +# Test the parsing of XS file-scoped syntax, apart from keywords (which +# are tested in 003-parse-file-scope-keywords.t) +# +# The tests in this file, and indeed in all 0xx-parse-foo.t files, only +# test parsing, and not compilation or execution of the C code. For the +# latter, see 3xx-run-foo.t files. + +use strict; +use warnings; +use Test::More; +use File::Spec; +use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib'); + +# Private test utilities +use TestMany; + +require_ok( 'ExtUtils::ParseXS' ); + +# Borrow the useful heredoc quoting/indenting function. +*Q = \&ExtUtils::ParseXS::Q; + +chdir('t') if -d 't'; +push @INC, '.'; + +package ExtUtils::ParseXS; +our $DIE_ON_ERROR = 1; +our $AUTHOR_WARNINGS = 1; +package main; + +{ + # Test POD + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "POD at EOF doesn't warn", + Q(<<'EOF'), + |void foo() + | + |=pod + |=cut +EOF + + [ 0, qr{XS}, "no undef warning" ], + ], + [ + "line continuation directly after POD", + Q(<<'EOF'), + |=pod + |=cut + |void foo(int i, \ + | int j) +EOF + + [ 0, qr{XS}, "no errs" ], + ], + ); + + test_many($preamble, undef, \@test_fns); +} + +{ + # Test standard C file preamble + # check that a few standard lines are present + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "C preamble", + Q(<<'EOF'), + |void foo() +EOF + + [ 0, qr{#ifndef PERL_UNUSED_VAR}, "PERL_UNUSED_VAR" ], + [ 0, qr{#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE}, + "PERL_ARGS_ASSERT_CROAK_XS_USAGE" ], + [ 0, qr{#ifdef newXS_flags}, "newXS_flags" ], + ], + ); + + test_many($preamble, undef, \@test_fns); +} + +{ + # An XS file without a MODULE line should warn, but + # still emit the C code in the C part of the file (the whole file + # contents in this case). + + my $preamble = ''; + + my @test_fns = ( + [ + "No MODULE line", + Q(<<'EOF'), + |foo + |bar +EOF + + [ 0, qr{#line 1 ".*"\nfoo\nbar\n#line 13 ".*"}, "all C present" ], + [ERR, qr{Warning: no MODULE line found in XS file \(input\)\n}, + "got expected MODULE warning" ], + ], + ); + + test_many($preamble, undef, \@test_fns); +} + + +{ + # Test C-preprocessor parsing + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "CPP basic", + Q(<<'EOF'), + |#ifdef USE_SHORT + | + |short foo() + | + |#elif USE_LONG + | + |long foo() + | + |#else + | + |int foo() + | + |#endif +EOF + [ 0, qr{ + ^ \#ifdef\ USE_SHORT \n + ^ \#define\ XSubPPtmpAAAA\ 1 \n + + .* + + ^ \s* short \s+ RETVAL; \s* \n + + .* + + ^ \#elif\ USE_LONG \n + ^ \#define\ XSubPPtmpAAAB\ 1 \n + + .* + + ^ \s* long \s+ RETVAL; \s* \n + + .* + + ^ \#else \n + ^ \#define\ XSubPPtmpAAAC\ 1 \n + + .* + + ^ \s* int \s+ RETVAL; \s* \n + + .* + ^ \#endif \n + + }smx, + "has corrrect XSubPPtmpAAAA etc definitions" + ], + + [ 0, qr{ + ^ \#if\ XSubPPtmpAAAA \n + .* newXS .* + ^ \#endif \n + ^ \#if\ XSubPPtmpAAAB \n + .* newXS .* + ^ \#endif \n + ^ \#if\ XSubPPtmpAAAC \n + .* newXS .* + ^ \#endif \n + + }smx, + "has corrrect XSubPPtmpAAAA etc boot usage" + ], + ], + + [ + "CPP basic, tightly cuddled", + Q(<<'EOF'), + |#ifdef USE_SHORT + |short foo() + |#elif USE_LONG + |long foo() + |#else + |int foo() + |#endif +EOF + [ 0, qr{ + ^ \#ifdef\ USE_SHORT \n + ^ \#define\ XSubPPtmpAAAA\ 1 \n + + .* + + ^ \s* short \s+ RETVAL; \s* \n + + .* + + ^ \#elif\ USE_LONG \n + ^ \#define\ XSubPPtmpAAAB\ 1 \n + + .* + + ^ \s* long \s+ RETVAL; \s* \n + + .* + + ^ \#else \n + ^ \#define\ XSubPPtmpAAAC\ 1 \n + + .* + + ^ \s* int \s+ RETVAL; \s* \n + + .* + ^ \#endif \n + + }smx, + "has corrrect XSubPPtmpAAAA etc definitions" + ], + + [ 0, qr{ + ^ \#if\ XSubPPtmpAAAA \n + .* newXS .* + ^ \#endif \n + ^ \#if\ XSubPPtmpAAAB \n + .* newXS .* + ^ \#endif \n + ^ \#if\ XSubPPtmpAAAC \n + .* newXS .* + ^ \#endif \n + + }smx, + "has corrrect XSubPPtmpAAAA etc boot usage" + ], + ], + + [ + "CPP two independent branches", + Q(<<'EOF'), + |#ifdef USE_SHORT + |short foo() + |#endif + |#if USE_LONG + |long foo() + |#endif +EOF + [ 0, qr{ + ^ \#ifdef\ USE_SHORT \n + ^ \#define\ XSubPPtmpAAAA\ 1 \n + .* + ^ \s* short \s+ RETVAL; \s* \n + .* + ^ \#endif \n + ^ \#if\ USE_LONG \n + ^ \#define\ XSubPPtmpAAAB\ 1 \n + .* + ^ \s* long \s+ RETVAL; \s* \n + .* + ^ \#endif \n + }smx, + "ifdefs in order" ], + ], + + [ + "CPP one branch, one main", + Q(<<'EOF'), + |#ifdef USE_SHORT + |short foo() + |#endif + |long foo() +EOF + [ 0, qr{ + ^ \#ifdef\ USE_SHORT \n + ^ \#define\ XSubPPtmpAAAA\ 1 \n + .* + ^ \s* short \s+ RETVAL; \s* \n + .* + ^ \#endif \n + .* + ^ \s* long \s+ RETVAL; \s* \n + }smx, + "ifdefs in order" ], + ], + + [ + "CPP two in one branch", + Q(<<'EOF'), + |#ifdef USE_SHORT + |short foo() + | + |long foo() + |#endif +EOF + [ERR, qr{Warning: duplicate function definition}, + "got expected warning" ], + ], + + [ + "CPP two in main", + Q(<<'EOF'), + |short foo() + | + |long foo() +EOF + [ERR, qr{Warning: duplicate function definition}, + "got expected warning" ], + ], + + [ + "CPP nested conditions", + Q(<<'EOF'), + |#ifdef C1 + | + |short foo() + | + |#ifdef C2 + | + |long foo() + | + |#endif + | + |int foo() + | + |#endif +EOF + [ERR, qr{Warning: duplicate function definition}, + "got expected warning" ], + ], + + [ + "CPP nested conditions, different fns", + Q(<<'EOF'), + |#ifdef C1 + | + |short foo() + | + |#ifdef C2 + | + |long bar() + | + |#endif + | + |int baz() + | + |#endif +EOF + [ 0, qr{ + ^ \#ifdef\ C1 \n + ^ \#define\ XSubPPtmpAAAB\ 1 \n + .* + ^ \s* short \s+ RETVAL; \s* \n + .* + ^ \#ifdef\ C2 \n + ^ \#define\ XSubPPtmpAAAA\ 1 \n + .* + ^ \s* long \s+ RETVAL; \s* \n + .* + ^ \#endif \n + .* + ^ \s* int \s+ RETVAL; \s* \n + .* + ^ \#endif \n + }smx, + "ifdefs in order" ], + ], + + [ + "CPP with indentation", + Q(<<'EOF'), + |#ifdef C1 + |# ifdef C2 + |long bar() + |# endif + |#endif +EOF + [ 0, qr{ + ^ \#ifdef\ C1 \n + ^ \#define\ XSubPPtmpAAAB\ 1 \n + ^ \s* \n + ^ \#\ \ ifdef\ C2 \n + ^ \#define\ XSubPPtmpAAAA\ 1 \n + .* + ^ \s* long \s+ RETVAL; \s* \n + .* + ^ \#\ \ endif \n + ^ \#endif \n + }smx, + "ifdefs in order" ], + ], + + [ + "CPP: trivial branch", + Q(<<'EOF'), + |#ifdef C1 + |#define BLAH1 + |#endif +EOF + [NOT, qr{XSubPPtmpAAA}, "no guard" ], + ], + + [ + "CPP: guard and other CPP ordering", + Q(<<'EOF'), + |#ifdef C1 + |#define BLAH1 + | + |short foo() + | + |#endif +EOF + + [ 0, qr{ + ^ \#ifdef\ C1 \n + .* + ^ \#define\ XSubPPtmpAAAA\ 1 \n + .* + ^ \#define\ BLAH1\n + .* + ^ \s* short \s+ RETVAL; \s* \n + .* + ^ \#endif \n + }smx, + "ifdefs in order" ], + ], + + [ + "CPP balanced else", + Q(<<'EOF'), + |#else + | + |short foo() +EOF + [ERR, qr{Error: '#else' with no matching '#if'}, + "got expected err" ], + ], + + [ + "CPP balanced if", + Q(<<'EOF'), + |#ifdef + | + |short foo() +EOF + [ERR, qr{Error: Unterminated '#ifdef' from line 5 in .* line 7}, + "got expected err" ], + ], + + [ + "indented file-scoped keyword", + Q(<<'EOF'), + |#define FOO 1 + | BOOT: +EOF + [ERR, qr{\QError: file-scoped keywords should not be indented\E + \Q in (input), line 5\E}x, + "got expected err" ], + ], + [ + "stray CPP / indented XSUB", + Q(<<'EOF'), + |#define FOO + | int +EOF + [ERR, qr{ + \QError: file-scoped directives must not be indented\E + \Q in (input), line 5\E\n + \Q (If this line is supposed to be part of an XSUB\E + }x, + "got expected err" ], + ], + + + ); + + test_many($preamble, undef, \@test_fns); +} + + + +done_testing; diff --git a/dist/ExtUtils-ParseXS/t/003-parse-file-scope-keywords.t b/dist/ExtUtils-ParseXS/t/003-parse-file-scope-keywords.t new file mode 100644 index 000000000000..285fb458a660 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/003-parse-file-scope-keywords.t @@ -0,0 +1,939 @@ +#!/usr/bin/perl +# +# 003-parse-file-scope-keywords.t: +# +# Test the parsing of XS file-scoped keywords. (N.B.: general file-scoped +# syntax is tested in 002-parse-file-scope.t) +# +# The tests in this file, and indeed in all 0xx-parse-foo.t files, only +# test parsing, and not compilation or execution of the C code. For the +# latter, see 3xx-run-foo.t files. + +use strict; +use warnings; +use Test::More; +use File::Spec; +use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib'); + +# Private test utilities +use TestMany; + +require_ok( 'ExtUtils::ParseXS' ); + +# Borrow the useful heredoc quoting/indenting function. +*Q = \&ExtUtils::ParseXS::Q; + +chdir('t') if -d 't'; +push @INC, '.'; + +package ExtUtils::ParseXS; +our $DIE_ON_ERROR = 1; +our $AUTHOR_WARNINGS = 1; +package main; + + +{ + # Check for correct package name; i.e. use the current package name, + # not the last one seen in the fil002-parse-file-scope.te. + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | + |TYPEMAP: <catdir(qw(t lib)) : 'lib'); + +# Private test utilities +use TestMany; + +require_ok( 'ExtUtils::ParseXS' ); + +# Borrow the useful heredoc quoting/indenting function. +*Q = \&ExtUtils::ParseXS::Q; + +chdir('t') if -d 't'; +push @INC, '.'; + +package ExtUtils::ParseXS; +our $DIE_ON_ERROR = 1; +our $AUTHOR_WARNINGS = 1; +package main; + + +{ + # Test XSUB declarations. + # Generates errors which don't result in an XSUB being emitted, + # so use 'undef' in the test_many() call to not strip down output + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "extern C", + Q(<<'EOF'), + |extern "C" int + |foo() +EOF + [ 0, qr/^extern "C"\nXS_EUPXS\(XS_Foo_foo\);/m, + "has extern decl" ], + ], + [ + "defn too short", + Q(<<'EOF'), + |int +EOF + [ERR, qr{ + \QError: unrecognised line: 'int' in (input), line 5\E\n + \Q (possible start of a truncated XSUB definition?)\E\n + }x, + "got err" ], + ], + [ + "defn not parseable 1", + Q(<<'EOF'), + |int + |foo(aaa + | CODE: + | AAA +EOF + [ERR, qr/\QError: cannot parse function definition from 'foo(aaa' in\E.*line 6/, + "got err" ], + ], + [ + "defn not parseable 2", + Q(<<'EOF'), + |int + |fo o(aaa) +EOF + [ERR, qr/\QError: cannot parse function definition from 'fo o(aaa)' in\E.*line 6/, + "got err" ], + ], + + # note that issuing this warning is somewhat controversial: + # see GH 19661. But while we continue to warn, test that we get a + # warning. + [ + "dup fn warning", + Q(<<'EOF'), + |int + |foo(aaa) + | + |int + |foo(aaa) +EOF + [ERR, qr/\QWarning: duplicate function definition 'foo' detected in\E.*line 9/, + "got warn" ], + ], + [ + "dup fn warning", + Q(<<'EOF'), + |#if X + |int + |foo(aaa) + | + |#else + |int + |foo(aaa) + |#endif +EOF + [ERR|NOT, qr/\QWarning: duplicate function definition/, + "no warning" ], + ], + + [ + "unparseable params", + Q(<<'EOF'), + |int foo(char *s = "abc\",)") +EOF + [ERR, qr/\QWarning: cannot parse parameter list/, + "got warning" ], + ], + ); + + test_many($preamble, undef, \@test_fns); +} + + +{ + # check that suitable "usage: " error strings are generated + # + # Note that some distros include a test of their usage strings which + # are sensitive to variations in white space, so these tests confirm + # that the exact white space is preserved, especially with regards to + # space (or not) around the '=' of a default value. + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "general usage msg", + Q(<<'EOF'), + |void + |foo(a, char *b, int length(b), int d = 999, ...) + | long a +EOF + [ 0, qr/usage\(cv,\s+"a, b, d= 999, ..."\)/, "" ], + ], + + # check that type and IN/OUT class etc are stripped out. + [ + "more usage msg", + Q(<<'EOF'), + |int + |foo( a , char * b , OUT int c , OUTLIST int d , \ + | IN_OUT char * * e = 1 + 2 , long length(b) , \ + | char* f="abc" , g = 0 , ... ) +EOF + [ 0, qr{usage\(cv,\s+\Q"a, b, c, e= 1 + 2, f=\E\\"abc\\"\Q, g = 0, ...")}, + "" ], + ] + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +{ + # check that args to an auto-called C function are correct + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "autocall args normal", + Q(<<'EOF'), + |void + |foo( OUT int a, b , char * c , int length(c), OUTLIST int d, IN_OUTLIST int e) + | long &b + | int alien +EOF + [ 0, qr/\Qfoo(&a, &b, c, XSauto_length_of_c, &d, &e)/, "" ], + ], + [ + "autocall args normal", + Q(<<'EOF'), + |void + |foo( OUT int a, b , char * c , size_t length(c) ) + | long &b + | int alien +EOF + [ 0, qr/\Qfoo(&a, &b, c, XSauto_length_of_c)/, "" ], + ], + + [ + "autocall args C_ARGS", + Q(<<'EOF'), + |void + |foo( int a, b , char * c ) + | C_ARGS: a, b , bar, c? c : "boo!" + | INPUT: + | long &b +EOF + [ 0, qr/\Qfoo(a, b , bar, c? c : "boo!")/, "" ], + ], + + [ + "autocall args empty C_ARGS", + Q(<<'EOF'), + |void + |foo(int a) + | C_ARGS: +EOF + [ 0, qr/\Qfoo()/, "" ], + ], + + [ + # Whether this is sensible or not is another matter. + # For now, just check that it works as-is. + "autocall args C_ARGS multi-line", + Q(<<'EOF'), + |void + |foo( int a, b , char * c ) + | C_ARGS: a, + | b , bar, + | c? c : "boo!" + | INPUT: + | long &b +EOF + [ 0, qr/\(a,\n b , bar,\n\Q c? c : "boo!")/, + "" ], + ], + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +{ + # Test prototypes + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: ENABLE + | + |TYPEMAP: < 0, inout => 0 ]); +} + + +{ + # Test default parameter values and ellipses + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + + # Basic int default + [ + "default i = 0", + Q(<<'EOF'), + |void + |foo(int i = 0) +EOF + [ 0, qr/^\s+int\s+i;$/m, "i delcared" ], + + [ 0, qr{\s+\Qif (items < 1)\E\n + \s+\Qi = 0;\E\n + \s+\Qelse {\E\n + \s+\Qi = (int)SvIV(ST(0))\E\n + \s*;\n + \s+}\n + }x, + "init" ], + ], + + # Basic char default + [ + "default c = 'x'", + Q(<<'EOF'), + |void + |foo(unsigned char c = 'x') +EOF + [ 0, qr/^\s+unsigned char\s+c;$/m, "c delcared" ], + + [ 0, qr{\s+\Qif (items < 1)\E\n + \s+\Qc = 'x';\E\n + \s+\Qelse {\E\n + \s+\Qc = (unsigned char)SvUV(ST(0))\E\n + \s*;\n + \s+}\n + }x, + "init" ], + ], + + # Basic string default + [ + 'default s = "abc"', + Q(<<'EOF'), + |void + |foo(char *s = "abc") +EOF + [ 0, qr/^\s+char \*\s+s;$/m, "s delcared" ], + + [ 0, qr{\s+\Qif (items < 1)\E\n + \s+\Qs = "abc";\E\n + \s+\Qelse {\E\n + \s+\Qs = (char *)SvPV_nolen(ST(0))\E\n + \s*;\n + \s+}\n + }x, + "init" ], + ], + + # mixed quote string default + [ + 'default s = "\'abc\'"', + Q(<<'EOF'), + |void + |foo(char *s = "'abc'") +EOF + [ 0, qr/^\s+char \*\s+s;$/m, "s delcared" ], + + [ 0, qr{\s+\Qif (items < 1)\E\n + \s+\Qs = "'abc'";\E\n + \s+\Qelse {\E\n + \s+\Qs = (char *)SvPV_nolen(ST(0))\E\n + \s*;\n + \s+}\n + }x, + "init" ], + ], + + # Check that default expressions are template-expanded. Whether + # this is sensible or not, Dynaloader and other distributions rely + # on it + [ + 'default expression expanded', + Q(<<'EOF'), + |void + |foo(char *s = "$Package") +EOF + [ 0, qr/^\s+s\s+=\s+"Foo"/m, "expanded" ], + ], + + # foo = + [ + 'default missing value', + Q(<<'EOF'), + |void + |foo(char *s = ) +EOF + [ERR, qr/Error: missing default value expression for 's'/m, + "got expected err" ], + + ], + + # Ellipses + + [ + "empty ellipsis", + Q(<<'EOF'), + |void + |foo(...) +EOF + [NOT, qr{if.*items}, "no checks" ], + ], + + [ + "ellipsis with 1 arg", + Q(<<'EOF'), + |void + |foo(int i, ...) +EOF + [ 0, qr{\s+\Qif (items < 1)\E\n + \s+\Qcroak_xs_usage(cv, "i, ...");\E\n + }x, + "check" ], + ], + [ + "ellipsis with 1 arg, 1 default arg", + Q(<<'EOF'), + |void + |foo(int i, int j = 0, ...) +EOF + [ 0, qr{\s+\Qif (items < 1)\E\n + \s+\Qcroak_xs_usage(cv, "i, j= 0, ...");\E\n + }x, + "check" ], + [ 0, qr[\s+\Qif (items < 2)\E\n + \s+\Qj = 0;\E\n + \s+\Qelse {\E\n + \s+\Qj = (int)SvIV(ST(1))\E\n + ]x, + "init" ], + ], + [ + "ellipsis with an ellipsis in default arg value", + Q(<<'EOF'), + |void + |foo(char *s = "...", int j = 0, ...) +EOF + [NOT, qr{croak_xs_usage}, "no check" ], + [ 0, qr[\s+\Qif (items < 1)\E\n + \s+\Qs = "...";\E\n + \s+\Qelse {\E\n + \s+\Qs = (char *)SvPV_nolen(ST(0))\E\n + ]x, + "init s" ], + [ 0, qr[\s+\Qif (items < 2)\E\n + \s+\Qj = 0;\E\n + \s+\Qelse {\E\n + \s+\Qj = (int)SvIV(ST(1))\E\n + ]x, + "init j" ], + [ 0, qr{\Qfoo(s, j)}, "autocall args" ], + ], + [ + "stuff after an ellipsis", + Q(<<'EOF'), + |void + |foo(..., int i) +EOF + [ERR, qr{\QError: further XSUB parameter seen after ellipsis}, + "saw error" ], + ], + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +done_testing; diff --git a/dist/ExtUtils-ParseXS/t/005-parse-parameters.t b/dist/ExtUtils-ParseXS/t/005-parse-parameters.t new file mode 100644 index 000000000000..5f8daf3269ac --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/005-parse-parameters.t @@ -0,0 +1,1344 @@ +#!/usr/bin/perl +# +# 005-parse-parameters.t +# +# Test the parsing of an individual parameter within the signature of an +# XSUB declaration. +# +# This concerned both with syntax, and some semantics, such as the +# processing of a parameter's type. +# +# There is a separate test file for XSUB return types, but some return +# type tests are here instead when they are testing same things that +# the corresponding parameter tests are doing. +# +# Note that there is a separate test file for INPUT and OUTPUT XSUB +# keywords. +# +# The tests in this file, and indeed in all 0xx-parse-foo.t files, only +# test parsing, and not compilation or execution of the C code. For the +# latter, see 3xx-run-foo.t files. + +use strict; +use warnings; +use Test::More; +use File::Spec; +use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib'); + +# Private test utilities +use TestMany; + +require_ok( 'ExtUtils::ParseXS' ); + +# Borrow the useful heredoc quoting/indenting function. +*Q = \&ExtUtils::ParseXS::Q; + +chdir('t') if -d 't'; +push @INC, '.'; + +package ExtUtils::ParseXS; +our $DIE_ON_ERROR = 1; +our $AUTHOR_WARNINGS = 1; +package main; + + +{ + # Test very basic type lookups + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "known type", + Q(<<'EOF'), + |void + |foo(int abc) +EOF + [ 0, qr/^\s+int\s+abc\s+=\s+\Q(int)SvIV(ST(0))/m, "" ], + ], + [ + "unknown type", + Q(<<'EOF'), + |void + |foo(blah abc) +EOF + [ERR, qr/Could not find a typemap for C type 'blah'/, " " ], + ], + [ + "custom type", + Q(<<'EOF'), + |TYPEMAP: <catdir(qw(t lib)) : 'lib'); + +# Private test utilities +use TestMany; + +require_ok( 'ExtUtils::ParseXS' ); + +# Borrow the useful heredoc quoting/indenting function. +*Q = \&ExtUtils::ParseXS::Q; + +chdir('t') if -d 't'; +push @INC, '.'; + +package ExtUtils::ParseXS; +our $DIE_ON_ERROR = 1; +our $AUTHOR_WARNINGS = 1; +package main; + + +{ + # Test return type declarations + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "NO_OUTPUT", + Q(<<'EOF'), + |NO_OUTPUT int + |foo() +EOF + [ 0, qr/\QRETVAL = foo();/, "has autocall" ], + [NOT, qr/\bTARG/, "no setting TARG" ], + [NOT, qr/\QST(0)/, "no setting ST(0)" ], + ], + [ + "xsub decl on one line", + Q(<<'EOF'), + | int foo(A, int B ) + | char *A +EOF + [ 0, qr/^\s+char \*\s+A\s+=/m, "has A decl" ], + [ 0, qr/^\s+int\s+B\s+=/m, "has B decl" ], + [ 0, qr/\QRETVAL = foo(A, B);/, "has autocall" ], + ], + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +{ + # Test RETVAL with the dXSTARG optimisation. When the return type + # corresponds to a simple sv_setXv($arg, $val) in the typemap, + # use the OP_ENTERSUB's TARG if possible, rather than creating a new + # mortal each time. + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | + |TYPEMAP: <catdir(qw(t lib)) : 'lib'); + +# Private test utilities +use TestMany; + +require_ok( 'ExtUtils::ParseXS' ); + +# Borrow the useful heredoc quoting/indenting function. +*Q = \&ExtUtils::ParseXS::Q; + +chdir('t') if -d 't'; +push @INC, '.'; + +package ExtUtils::ParseXS; +our $DIE_ON_ERROR = 1; +our $AUTHOR_WARNINGS = 1; +package main; + + +{ + # Test INPUT: keyword + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "INPUT bad line", + Q(<<'EOF'), + |int + |foo(abc) + | int + foo; +EOF + [ERR, qr/^\QError: invalid parameter declaration ' int + foo;'\E.* line 7\n/, "got expected error" ], + ], + [ + "INPUT no length()", + Q(<<'EOF'), + |int + |foo(abc) + | int length(abc) +EOF + [ERR, qr/^\QError: length() not permitted in INPUT section\E.* line 7\n/, "got expected error" ], + ], + [ + "INPUT dup", + Q(<<'EOF'), + |int + |foo(abc, int def) + | int abc + | int abc + | int def +EOF + [ERR, qr/^\QError: duplicate definition of parameter 'abc' ignored in\E.* line 8\n/m, + "abc: got expected error" ], + + [ERR, qr/^\QError: duplicate definition of parameter 'def' ignored in\E.* line 9\n/m, + "def: got expected error" ], + ], + + + + # Tests for [=+;] initialisers on INPUT lines (including embedded + # double quotes within the expression, which get evalled) + + [ + "INPUT '='", + + Q(<<'EOF'), + |int + |foo(abc) + |int abc = ($var"$var\"$type); +EOF + [ 0, qr/^ \s+ int \s+ abc\ =\ \Q(abc"abc"int);\E $/mx, + "typemap was expanded" ], + + ], + [ + "INPUT ';'", + Q(<<'EOF'), + |int + |foo(abc, long xyz) + |int abc ; blah($var"$var\"$type); +EOF + [ 0, qr/^ \s+ int \s+ abc;$/mx, + "declaration doesn't have init" ], + [ 0, qr/xyz .*\n.*\Qblah(abc"abc"int);\E$/msx, + "init code deferred and present" ], + + ], + [ + "INPUT '+'", + Q(<<'EOF'), + |int + |foo(abc, long xyz) + |int abc + blurg($var"$var\"$type); +EOF + [ 0, qr/^ \s+ int \s+ abc \s+ = \s+ \Q(int)SvIV(ST(0))\E\n; $/mx, + "std typemap was used and expanded" ], + [ 0, qr/xyz .*\n.*\Qblurg(abc"abc"int);\E$/msx, + "deferred code present" ], + + ], + + # Tests for [=+;] initialisers on INPUT lines mixed with + # default values + + [ + "default value and INPUT '='", + + Q(<<'EOF'), + |int + |foo(abc = 111) + |int abc = 777; +EOF + [ TODO, qr/if\s*\(items < 1\)\n\s*abc = 111;\n\s*else \{\n\s*abc = 777;\n\}\n/, + "", + "default is lost in presence of initialiser", + ], + + ], + [ + "default value and INPUT ';'", + Q(<<'EOF'), + |int + |foo(abc = 111, long xyz) + |int abc ; 777; +EOF + [ 0, qr/^ \s+ int \s+ abc;$/mx, + "declaration doesn't have init" ], + [ 0, qr/xyz .*\n.*^777;$/msx, + "init code deferred and present" ], + + ], + [ + "default value and INPUT '+'", + Q(<<'EOF'), + |int + |foo(abc = 111, long xyz) + |int abc + 777; +EOF + [ 0, qr/^ \s+ int \s+ abc;$/mx, + "declaration doesn't have init" ], + [ 0, qr/ + \Qif (items < 1)\E\n + \s+\Qabc = 111;\E\n + \s+\Qelse {\E\n + \s+\Qabc = (int)SvIV(ST(0))\E\n + /msx, + "conditional init code present" ], + + [ 0, qr/ + \s+\Qabc = (int)SvIV(ST(0))\E\n + \s*;\n\s*\}\n777; + /msx, + "deferred code present" ], + ], + + # Tests for [=+;] initialisers on INPUT lines mixed with + # NO_INIT default values + + [ + "NO_INIT default value and INPUT '='", + + Q(<<'EOF'), + |int + |foo(abc = NO_INIT) + |int abc = 777; +EOF + [ TODO, qr/if\s*\(items >= 1\)\n\s*abc = 777;\n\s*}/, + "", + "default is lost in presence of initialiser", + ], + + ], + [ + "NO_INIT default value and INPUT ';'", + Q(<<'EOF'), + |int + |foo(abc = NO_INIT, long xyz) + |int abc ; 777; +EOF + [ 0, qr/^ \s+ int \s+ abc;$/mx, + "declaration doesn't have init" ], + [ 0, qr/xyz .*\n.*^777;$/msx, + "init code deferred and present" ], + + ], + [ + "NO_INIT default value and INPUT '+'", + Q(<<'EOF'), + |int + |foo(abc = NO_INIT, long xyz) + |int abc + 777; +EOF + [ 0, qr/^ \s+ int \s+ abc;$/mx, + "declaration doesn't have init" ], + [ 0, qr/ + \Qif (items >= 1) {\E\n + \s+\Qabc = (int)SvIV(ST(0))\E\n + /msx, + "conditional init code present" ], + + [ 0, qr/\s*;\n\s*\}\n777; /msx, + "deferred code present" ], + ], + + # Test for initialisers with unknown variable type. + # This previously died. + + [ + "INPUT initialiser with unknown type", + Q(<<'EOF'), + |void foo(a, b, c) + | UnknownType1 a = NO_INIT + | UnknownType2 b = bar(); + | UnknownType3 c = baz($arg); +EOF + [ 0, qr/UnknownType1\s+a;/mx, "a decl" ], + [ 0, qr/UnknownType2\s+\Qb = bar();\E/mx, "b decl" ], + [ 0, qr/UnknownType3\s+\Qc = baz(ST(2));\E/mx, "c decl" ], + ], + + # Test 'alien' INPUT parameters: ones which are declared in an INPUT + # section but don't appear in the XSUB's signature. This ought to be + # a compile error, but people rely on it to declare and initialise + # variables which ought to be in a PREINIT or CODE section. + + [ + "alien INPUT vars", + Q(<<'EOF'), + |void foo() + | long alien1 + | int alien2 = 123; + | # see perl #112776 + | SV *alien3 = sv_2mortal(newSV()); +EOF + [ 0, qr/long\s+alien1;\n/, "alien1 decl" ], + [ 0, qr/int\s+alien2 = 123;\n/, "alien2 decl" ], + [ 0, qr/SV \*\s+alien3 = \Qsv_2mortal(newSV());\E\n/, "alien3 decl" ], + ], + + # Test for 'length(foo)' not legal in INPUT section + + [ + "alien INPUT vars", + Q(<<'EOF'), + |void foo(s) + | char *s + | int length(s) +EOF + [ERR, qr/\QError: length() not permitted in INPUT section/, + "got expected err" ], + ], + + # Test for "duplicate definition of argument" errors + + [ + "duplicate INPUT vars", + Q(<<'EOF'), + |void foo(abc) + | int abc; + | int abc; +EOF + [ERR, qr/\QError: duplicate definition of parameter 'abc'/, + "got expected err" ], + ], + [ + "duplicate INPUT and signature vars", + Q(<<'EOF'), + |void foo(int abc) + | int abc; +EOF + [ERR, qr/\QError: duplicate definition of parameter 'abc'/, + "got expected err" ], + ], + [ + "duplicate alien INPUT vars", + Q(<<'EOF'), + |void foo() + | int abc; + | int abc; +EOF + [ERR, qr/\QError: duplicate definition of parameter 'abc'/, + "got expected err" ], + ], + + # Missing initialiser + + [ + "INPUT: missing '=' initialiser", + Q(<<'EOF'), + |void foo(abc) + | int abc = +EOF + [ERR, qr/\QError: missing '=' initialiser value/, + "got expected err" ], + ], + [ + "INPUT: missing '=' initialiser with semicolon", + Q(<<'EOF'), + |void foo(abc) + | int abc = ; +EOF + [ERR, qr/\QError: missing '=' initialiser value/, + "got expected err" ], + ], + [ + "INPUT: missing '+' initialiser", + Q(<<'EOF'), + |void foo(abc) + | int abc + +EOF + [ERR, qr/\QError: missing '+' initialiser value/, + "got expected err" ], + ], + [ + "INPUT: missing '+' initialiser with semicolon", + Q(<<'EOF'), + |void foo(abc) + | int abc + ; +EOF + [ERR, qr/\QError: missing '+' initialiser value/, + "got expected err" ], + ], + [ + "INPUT: NOT missing ';' initialiser", + Q(<<'EOF'), + |void foo(abc) + | int abc ; +EOF + # this is NOT an error + ], + [ + "INPUT: missing ';' initialiser with semicolon", + Q(<<'EOF'), + |void foo(abc) + | int abc ; ; +EOF + [ERR, qr/\QError: missing ';' initialiser value/, + "got expected err" ], + ], + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +{ + # Test OUTPUT: keyword + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | + |TYPEMAP: <catdir(qw(t lib)) : 'lib'); + +# Private test utilities +use TestMany; + +require_ok( 'ExtUtils::ParseXS' ); + +# Borrow the useful heredoc quoting/indenting function. +*Q = \&ExtUtils::ParseXS::Q; + +chdir('t') if -d 't'; +push @INC, '.'; + +package ExtUtils::ParseXS; +our $DIE_ON_ERROR = 1; +our $AUTHOR_WARNINGS = 1; +package main; + + +{ + # Test ALIAS keyword - boot code + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "ALIAS basic", + Q(<<'EOF'), + |void + |foo() + | ALIAS: foo = 1 + | bar = 2 + | Baz::baz = 3 + | boz = BOZ_VAL + | buz => foo + | baz => buz + | biz => Baz::baz +EOF + [ 0, qr{"Foo::foo",.*\n.*= 1;}, + "has Foo::foo" ], + [ 0, qr{"Foo::bar",.*\n.*= 2;}, + "has Foo::bar" ], + [ 0, qr{"Baz::baz",.*\n.*= 3;}, + "has Baz::baz" ], + [ 0, qr{"Foo::boz",.*\n.*= BOZ_VAL;}, + "has Foo::boz" ], + [ 0, qr{"Foo::buz",.*\n.*= 1;}, + "has Foo::buz" ], + [ 0, qr{"Foo::baz",.*\n.*= 1;}, + "has Foo::baz" ], + [ 0, qr{"Foo::biz",.*\n.*= 3;}, + "has Foo::biz" ], + [ 0, qr{\QCV * cv;}, "has cv declaration" ], + ], + + [ + "ALIAS with main as default of 0", + Q(<<'EOF'), + |void + |foo() + | ALIAS: + | bar = 2 + | baz = foo + | boz = 0 +EOF + [ 0, qr{"Foo::foo",.*\n.*= 0;}, + "has Foo::foo" ], + [ 0, qr{"Foo::bar",.*\n.*= 2;}, + "has Foo::bar" ], + [ 0, qr{"Foo::baz",.*\n.*= foo;}, + "has Foo::baz" ], + [ 0, qr{"Foo::boz",.*\n.*= 0;}, + "has Foo::boz" ], + [ERR, qr{\QWarning: aliases 'boz' and 'foo' have identical\E + \Q values of 0 - the base function in (input), line 10\E + }x, + "got dup warning" ], + ], + + [ + "ALIAS multi-perl-line, blank lines", + Q(<<'EOF'), + |void + |foo() + | ALIAS: foo = 1 bar = 2 + | + | Baz::baz = 3 boz = BOZ_VAL + | buz => foo + | biz => Baz::baz + | + | +EOF + [ 0, qr{"Foo::foo",.*\n.*= 1;}, + "has Foo::foo" ], + [ 0, qr{"Foo::bar",.*\n.*= 2;}, + "has Foo::bar" ], + [ 0, qr{"Baz::baz",.*\n.*= 3;}, + "has Baz::baz" ], + [ 0, qr{"Foo::boz",.*\n.*= BOZ_VAL;}, + "has Foo::boz" ], + [ 0, qr{"Foo::buz",.*\n.*= 1;}, + "has Foo::buz" ], + [ 0, qr{"Foo::biz",.*\n.*= 3;}, + "has Foo::biz" ], + ], + + [ + "ALIAS no colon", + Q(<<'EOF'), + |void + |foo() + | ALIAS: bar = X::Y +EOF + [ERR, qr{\QError: in alias definition for 'bar' the value may not contain ':' unless it is symbolic.\E.*line 7}, + "got expected error" ], + ], + + [ + "ALIAS unknown alias", + Q(<<'EOF'), + |void + |foo() + | ALIAS: Foo::bar => blurt +EOF + [ERR, qr{\QError: unknown alias 'Foo::blurt' in symbolic definition for 'Foo::bar'\E.*line 7}, + "got expected error" ], + ], + + [ + "ALIAS warn duplicate", + Q(<<'EOF'), + |void + |foo() + | ALIAS: bar = 1 + | bar = 1 +EOF + [ERR, qr{\QWarning: ignoring duplicate alias 'bar'\E.*line 8}, + "got expected warning" ], + ], + [ + "ALIAS warn conflict duplicate", + Q(<<'EOF'), + |void + |foo() + | ALIAS: bar = 1 + | bar = 2 +EOF + [ERR, qr{\QWarning: conflicting duplicate alias 'bar'\E.*line 8}, + "got expected warning" ], + ], + + [ + "ALIAS warn identical values", + Q(<<'EOF'), + |void + |foo() + | ALIAS: bar = 1 + | baz = 1 +EOF + [ERR, qr{\QWarning: aliases 'baz' and 'bar' have identical values of 1\E.*line 8}, + "got expected warning" ], + ], + + [ + "ALIAS warn twin identical values", + Q(<<'EOF'), + |void + |foo() + | ALIAS: a1 = 1 + | a2 => a1 + | a3 = 1 + | a4 = 1 +EOF + [ERR, qr{\QWarning: aliases 'a3' and 'a1', 'a2'\E + \Q have identical values of 1 in (input), line 9\E\n + \Q (If this is deliberate use a symbolic alias instead.)\E + }x, + "got a3 warning" ], + [ERR, qr{\QWarning: aliases 'a4' and 'a1', 'a2', 'a3'\E + \Q have identical values of 1 in (input), line 10\E\n\z + }x, + "got a4 warning, no hint" ], + ], + + [ + "ALIAS warn identical 0 values", + Q(<<'EOF'), + |void + |foo() + | ALIAS: b1 = 0 + | foo = 0 + | b2 = 0 +EOF + [ERR, qr{\QWarning: aliases 'b1' and 'foo'\E + \Q have identical values of 0\E + \Q - the base function in (input), line 7\E\n + \Q (If this is deliberate use a symbolic alias instead.)\E + }x, + "got b1 warning" ], + [ERR, qr{\QWarning: aliases 'foo' and 'b1', 'foo'\E + \Q have identical values of 0\E + \Q - the base function in (input), line 8\E\n + }x, + "got foo warning" ], + [ERR, qr{\QWarning: aliases 'b2' and 'b1', 'foo'\E + \Q have identical values of 0\E + \Q - the base function in (input), line 9\E\n\z + }x, + "got b2 warning, no hint" ], + ], + + [ + "ALIAS warn varying values", + Q(<<'EOF'), + |void + |foo() + | ALIAS: c1 = 1 + | c1 = 2 +EOF + [ERR, qr{\QWarning: conflicting duplicate alias 'c1' changes\E + \Q definition from '1' to '2' in\E + \Q (input), line 8\E\n\z + }x, + "got c1 warning" ], + ], + + [ + "ALIAS unparseable entry", + Q(<<'EOF'), + |void + |foo() + | ALIAS: bar = +EOF + [ERR, qr{\QError: cannot parse ALIAS definitions from 'bar ='\E.*line 7}, + "got expected error" ], + ], + [ + "ALIAS zero", # zero used to be silently ignored + Q(<<'EOF'), + |void + |foo() + | ALIAS: 0 +EOF + [ERR, qr{\QError: cannot parse ALIAS definitions from '0'\E.*line 7}, + "got expected error" ], + ], + [ + "ALIAS empty", + Q(<<'EOF'), + |void + |foo() + | ALIAS: +EOF + # just concerend with not getting an error + ], + ); + + test_many($preamble, 'boot_Foo', \@test_fns); +} + + +{ + # Test ALIAS keyword - with AUTHOR_WARNINGS disabled + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + + [ + "ALIAS no warn identical values under no author tests", + Q(<<'EOF'), + |void + |foo() + | ALIAS: bar = 1 + | baz = 1 +EOF + [ 0, qr{"Foo::foo",.*\n.*= 0;}, + "has Foo::foo" ], + [ 0, qr{"Foo::bar",.*\n.*= 1;}, + "has Foo::bar" ], + [ 0, qr{"Foo::baz",.*\n.*= 1;}, + "has Foo::baz" ], + # and no warnings expected + ], + ); + + test_many($preamble, 'boot_Foo', \@test_fns, [ author_warnings => 0 ]); +} + + +{ + # Test ALIAS keyword - XSUB body + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + 'ALIAS with $ALIAS used in typemap entry', + Q(<<'EOF'), + |void + |foo(AV *av) + | ALIAS: bar = 1 +EOF + [ 0, qr{croak.*\n.*\QGvNAME(CvGV(cv))}, + "got alias variant of croak message" ], + ], + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +{ + # Test ATTRS keyword + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "ATTRS basic", + Q(<<'EOF'), + |void + |foo() + | ATTRS: a + | b c(x) + | C_ARGS: foo + | ATTRS: d(y( z)) +EOF + [ 0, qr{\QCV * cv;}, "has cv declaration" ], + [ 0, qr{\Qapply_attrs_string("Foo", cv, "a\E\s+b\s+c\(x\)\s+\Qd(y( z))", 0);}, + "has correct attrs arg" ], + ], + + ); + + test_many($preamble, 'boot_Foo', \@test_fns); +} + + +{ + # Test CASE: blocks + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + + [ + "CASE with dup INPUT and OUTPUT", + Q(<<'EOF'), + |int + |foo(abc, def) + | CASE: X + | int abc; + | short def; + | CODE: + | RETVAL = abc + def; + | OUTPUT: + | RETVAL + | + | CASE: Y + | long abc; + | long def; + | CODE: + | RETVAL = abc - def; + | OUTPUT: + | RETVAL +EOF + [ 0, qr/_usage\(cv,\s*"abc, def"\)/, "usage" ], + + [ 0, qr/ + if \s* \(X\) + .* + int \s+ abc \s* = [^\n]* ST\(0\) + .* + else \s+ if \s* \(Y\) + /xs, "1st abc is int and ST(0)" ], + [ 0, qr/ + else \s+ if \s* \(Y\) + .* + long \s+ abc \s* = [^\n]* ST\(0\) + /xs, "2nd abc is long and ST(0)" ], + [ 0, qr/ + if \s* \(X\) + .* + short \s+ def \s* = [^\n]* ST\(1\) + .* + else \s+ if \s* \(Y\) + /xs, "1st def is short and ST(1)" ], + [ 0, qr/ + else \s+ if \s* \(Y\) + .* + long \s+ def \s* = [^\n]* ST\(1\) + /xs, "2nd def is long and ST(1)" ], + [ 0, qr/ + if \s* \(X\) + .* + int \s+ RETVAL; + .* + else \s+ if \s* \(Y\) + /xs, "1st RETVAL is int" ], + [ 0, qr/ + else \s+ if \s* \(Y\) + .* + int \s+ RETVAL; + .* + /xs, "2nd RETVAL is int" ], + + [ 0, qr/ + if \s* \(X\) + .* + \QRETVAL = abc + def;\E + .* + else \s+ if \s* \(Y\) + /xs, "1st RETVAL assign" ], + [ 0, qr/ + else \s+ if \s* \(Y\) + .* + \QRETVAL = abc - def;\E + .* + /xs, "2nd RETVAL assign" ], + + [ 0, qr/\b\QXSRETURN(1)/, "ret 1" ], + [NOT, qr/\bXSRETURN\b.*\bXSRETURN/s, "only a single XSRETURN" ], + ], + [ + "CASE with unconditional else", + Q(<<'EOF'), + |void + |foo() + | CASE: CCC1 + | CODE: + | YYY1 + | CASE: CCC2 + | CODE: + | YYY2 + | CASE: + | CODE: + | YYY3 +EOF + [ 0, qr/ + ^ \s+ if \s+ \(CCC1\) \n + ^ \s+ \{ \n + .* + ^\s+ YYY1 \n + .* + ^ \s+ \} \n + ^ \s+ else \s+ if \s+ \(CCC2\) \n + ^ \s+ \{ \n + .* + ^\s+ YYY2 \n + .* + ^ \s+ \} \n + ^ \s+ else \n + ^ \s+ \{ \n + .* + ^\s+ YYY3 \n + .* + ^ \s+ \} \n + ^ \s+ XSRETURN_EMPTY;\n + + /xms, "all present in order" ], + ], + [ + "CASE with dup alien var", + Q(<<'EOF'), + |void + |foo(abc) + | CASE: X + | int abc + | int def + | CASE: Y + | long abc + | long def +EOF + [ 0, qr/ + if \s* \(X\) + .* + int \s+ def \s*; + .* + else \s+ if \s* \(Y\) + .* + long \s+ def \s*; + /xs, "two alien declarations" ], + ], + [ + "CASE with variant keywords", + Q(<<'EOF'), + |void + |foo() + | CASE: X + | C_ARGS: x,y + | CASE: Y + | C_ARGS: y,x +EOF + [ 0, qr/\(x,y\).*\(y,x\)/s, "C_ARGS" ], + ], + [ + "CASE with variant THIS type", + Q(<<'EOF'), + |void + |A::B::foo() + | CASE: X + | int THIS + | CASE: Y + | long THIS + | CASE: + | short THIS +EOF + [ 0, qr/int \s+ THIS .* + long \s+ THIS .* + short \s+ THIS/sx, "has three types" ], + ], + [ + "CASE with variant RETVAL type", + Q(<<'EOF'), + |int + |foo() + | CASE: X + | long RETVAL + | CASE: Y + | double RETVAL + | CASE: Z + | char * RETVAL +EOF + [ 0, qr/long \s+ RETVAL .* + double \s+ RETVAL .* + char \s* \* \s+ RETVAL/sx, "has three decl types" ], + [ 0, qr/X .* TARGi .* + Y .* TARGi .* + Z .* TARGi .*/sx, "has one setting type" ], + ], + [ + "CASE with variant autocall RETVAL", + Q(<<'EOF'), + |int + |foo(int a) + | CASE: X + | + | CASE: Y + | CODE: + | YYY +EOF + [ 0, qr{\Qif (X)\E + .* + dXSTARG; + .* + \QTARGi((IV)RETVAL, 1);\E + .* + \Qelse if (Y)\E + }sx, "branch X returns RETVAL" ], + + [NOT, qr{\Qelse if (Y)\E + .* + \QPUSHi((IV)RETVAL);\E + }sx, "branch Y doesn't return RETVAL" ], + ], + [ + "CASE with variant deferred var inits", + Q(<<'EOF'), + |int + |foo(abc) + | CASE: X + | AV *abc + | + | CASE: Y + | HV *abc +EOF + [ 0, qr{\Qif (X)\E + .* + croak.*\Qnot an ARRAY reference\E + .* + \Qelse if (Y)\E + .* + croak.*\Qnot a HASH reference\E + }sx, "differing croaks" ], + + ], + + [ + "CASE: case follows unconditional CASE", + Q(<<'EOF'), + |int + |foo() + | CASE: X + | CODE: + | AAA + | CASE: + | CODE: + | BBB + | CASE: Y + | CODE: + | CCC +EOF + [ERR, qr/\QError: 'CASE:' after unconditional 'CASE:'/, + "expected err" ], + ], + [ + "CASE: not at top of function", + Q(<<'EOF'), + |int + |foo() + | CODE: + | AAA + | CASE: X + | CODE: +EOF + [ERR, qr/\QError: no 'CASE:' at top of function/, + "expected err" ], + ], + [ + "CASE: junk", + Q(<<'EOF'), + |int + |foo(a) + |CASE: X + | SCOPE: ENABLE + | INPUTx: +EOF + [ERR, qr/\QError: junk at end of function: " INPUTx:" in /, + "expected err" ], + ], + [ + "keyword after end of xbody", + Q(<<'EOF'), + |void + |foo() + | CODE: + | abc + | C_ARGS: +EOF + [ERR, qr{\QError: misplaced 'C_ARGS:' in\E.*line 8}, + "got expected error" ], + ], + + [ + "CASE: setting ST(0)", + Q(<<'EOF'), + |void + |foo(a) + |CASE: X + | CODE: + | ST(0) = 1; + |CASE: Y + | CODE: + | blah +EOF + [ERR, qr/\QWarning: ST(0) isn't consistently set in every CASE's CODE block/, + "expected err" ], + ], + + [ + "CASE: not at top", + Q(<<'EOF'), + |int abc(int x, int y) + | INIT: + | myinit + | CASE: x > 0 + | CODE: + | code1; + | CASE: + | CODE: + | code2; +EOF + [ERR, qr/\A\QError: no 'CASE:' at top of function in (input), line 8\E\n\z/, + "only the expected err" ], + ], + + + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +{ + # Test CLEANUP keyword + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "CLEANUP basic", + Q(<<'EOF'), + |int + |foo(int aaa) + | CLEANUP: + | YYY +EOF + [ 0, qr{\bint\s+aaa}, "has aaa decl" ], + [ 0, qr{^\s+\QRETVAL = foo(aaa);}m, "has code body" ], + [ 0, qr{^\s+YYY\n}m, "has cleanup body" ], + [ 0, qr{aaa.*foo\(aaa\).*TARGi.*YYY}s, "in sequence" ], + [ 0, qr{\#line 8 .*\n\s+YYY}, "correct #line" ], + ], + [ + "CLEANUP empty", + Q(<<'EOF'), + |void + |foo(int aaa) + | CLEANUP: +EOF + [ 0, qr{\bint\s+aaa}, "has aaa decl" ], + [ 0, qr{^\s+\Qfoo(aaa);}m, "has code body" ], + [ 0, qr{\Qfoo(aaa);\E\n\#line 8 }, "correct #line" ], + ], + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +{ + # Test CODE keyword + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "CODE basic", + Q(<<'EOF'), + |void + |foo(int aaa) + | CODE: + | YYY +EOF + [ 0, qr{\bint\s+aaa}, "has aaa decl" ], + [ 0, qr{YYY}, "has code body" ], + [ 0, qr{aaa.*YYY}s, "in sequence" ], + [ 0, qr{\#line 8 .*\n\s+YYY}, "correct #line" ], + ], + [ + "CODE empty", + Q(<<'EOF'), + |void + |foo(int aaa) + | CODE: +EOF + [ 0, qr{\bint\s+aaa}, "has aaa decl" ], + [ 0, qr{aaa.*\n\s*;\s*\n\#line 8 }, "correct #line" ], + ], + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +{ + # Test INIT: keyword + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "INIT basic", + Q(<<'EOF'), + |void + |foo(aaa, short bbb) + | int aaa + | INIT: + | XXX + | YYY + | CODE: + | ZZZ +EOF + [ 0, qr{\bint\s+aaa}, "has aaa decl" ], + [ 0, qr{\bshort\s+bbb}, "has bbb decl" ], + [ 0, qr{^\s+XXX\n\s+YYY\n}m, "has XXX, YYY" ], + [ 0, qr{^\s+ZZZ\n}m, "has ZZZ" ], + [ 0, qr{aaa.*bbb.*XXX.*YYY.*ZZZ}s,"in sequence" ], + ], + + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +{ + # Test INTERFACE keyword - boot code + + my $preamble = Q(<<'EOF'); + |MODULE = Foo::Bar PACKAGE = Foo::Bar PREFIX = foobar_ + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "INTERFACE basic boot", + Q(<<'EOF'), + |void + |foo() + | INTERFACE: f1 f2 +EOF + [ 0, qr{ \QnewXS_deffile("Foo::Bar::f1", XS_Foo__Bar_foo);\E\n + \s+\QXSINTERFACE_FUNC_SET(cv,f1);\E + }x, + "got f1 entries" ], + [ 0, qr{ \QnewXS_deffile("Foo::Bar::f2", XS_Foo__Bar_foo);\E\n + \s+\QXSINTERFACE_FUNC_SET(cv,f2);\E + }x, + "got f2 entries" ], + [ 0, qr{\QCV * cv;}, "has cv declaration" ], + ], + [ + "INTERFACE with MACRO", + Q(<<'EOF'), + |void + |foo() + | INTERFACE: f1 f2 + | INTERFACE_MACRO: GETMACRO SETMACRO +EOF + [ 0, qr{ \QnewXS_deffile("Foo::Bar::f1", XS_Foo__Bar_foo);\E\n + \s+\QSETMACRO(cv,f1);\E + }x, + "got f1 entries" ], + [ 0, qr{ \QnewXS_deffile("Foo::Bar::f2", XS_Foo__Bar_foo);\E\n + \s+\QSETMACRO(cv,f2);\E + }x, + "got f2 entries" ], + [ 0, qr{\QCV * cv;}, "has cv declaration" ], + ], + + # Assorted name mangling - test the table in perlxs: + # + # Interface name Perl function name C function name + # -------------- ------------------ ---------------- + # abc Foo::Bar::abc abc + # foobar_abc Foo::Bar::abc foobar_abc + # X::Y::foobar_def X::Y::foobar_def X::Y::foobar_def + + [ + 'INTERFACE simple name', + Q(<<'EOF'), + |void + |foo() + | INTERFACE: abc +EOF + [ 0, qr{newXS.*"Foo::Bar::abc"}, "perl name" ], + [ 0, qr{newXS.*XS_Foo__Bar_foo}, "XS name" ], + [ 0, qr{\QXSINTERFACE_FUNC_SET(cv,abc)}, "C name" ], + ], + [ + 'INTERFACE name with prefix', + Q(<<'EOF'), + |void + |foo() + | INTERFACE: foobar_abc +EOF + [ 0, qr{newXS.*"Foo::Bar::abc"}, "perl name" ], + [ 0, qr{newXS.*XS_Foo__Bar_foo}, "XS name" ], + [ 0, qr{\QXSINTERFACE_FUNC_SET(cv,foobar_abc)}, "C name" ], + ], + [ + 'INTERFACE name with class', + Q(<<'EOF'), + |void + |foo() + | INTERFACE: X::Y::foobar_abc +EOF + [ 0, qr{newXS.*"X::Y::foobar_abc"}, "perl name" ], + [ 0, qr{newXS.*XS_Foo__Bar_foo}, "XS name" ], + [ 0, qr{\QXSINTERFACE_FUNC_SET(cv,X::Y::foobar_abc)}, "C name"], + ], + ); + + test_many($preamble, 'boot_Foo', \@test_fns); +} + +{ + # Test INTERFACE keyword - XSUB body + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | + |TYPEMAP: < + | + - * / + | OVERLOAD: > < >= +EOF + [ 0, qr{\Q"Foo::(*"}, "has Foo::(* method" ], + [ 0, qr{\Q"Foo::(+"}, "has Foo::(+ method" ], + [ 0, qr{\Q"Foo::(-"}, "has Foo::(- method" ], + [ 0, qr{\Q"Foo::(/"}, "has Foo::(/ method" ], + [ 0, qr{\Q"Foo::(<"}, "has Foo::(< method" ], + [ 0, qr{\Q"Foo::(<=>"}, "has Foo::(<=> method" ], + [ 0, qr{\Q"Foo::(>"}, "has Foo::(> method" ], + [ 0, qr{\Q"Foo::(>="}, "has Foo::(>= method" ], + [ 0, qr{\Q"Foo::(cmp"}, "has Foo::(cmp method" ], + ], + [ + "OVERLOAD dup op", + Q(<<'EOF'), + |void + |foo() + | OVERLOAD: cmp cmp +EOF + [ERR, qr{\QWarning: duplicate OVERLOAD op name: 'cmp'}, + "got expected error" ], + ], + + ); + + test_many($preamble, 'boot_Foo', \@test_fns); +} + + +{ + # Test POSTCALL keyword + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "POSTCALL basic", + Q(<<'EOF'), + |int + |foo(int aaa) + | POSTCALL: + | YYY +EOF + [ 0, qr{\bint\s+aaa}, "has aaa decl" ], + [ 0, qr{^\s+\QRETVAL = foo(aaa);}m, "has code body" ], + [ 0, qr{^\s+YYY\n}m, "has postcall body" ], + [ 0, qr{aaa.*foo\(aaa\).*YYY.*TARGi}s, "in sequence" ], + [ 0, qr{\#line 8 .*\n\s+YYY}, "correct #line" ], + ], + [ + "POSTCALL empty", + Q(<<'EOF'), + |void + |foo(int aaa) + | POSTCALL: +EOF + [ 0, qr{\bint\s+aaa}, "has aaa decl" ], + [ 0, qr{^\s+\Qfoo(aaa);}m, "has code body" ], + [ 0, qr{\Qfoo(aaa);\E\n\#line 8 }, "correct #line" ], + ], + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +{ + # Test PPCODE keyword + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "PPCODE basic", + Q(<<'EOF'), + |void + |foo(int aaa) + | PPCODE: + | YYY +EOF + [ 0, qr{\bint\s+aaa}, "has aaa decl" ], + [ 0, qr{YYY}, "has code body" ], + [ 0, qr{aaa.*YYY}s, "in sequence" ], + [ 0, qr{\#line 8 .*\n\s+YYY}, "correct #line" ], + ], + [ + "PPCODE empty", + Q(<<'EOF'), + |void + |foo(int aaa) + | PPCODE: +EOF + [ 0, qr{\bint\s+aaa}, "has aaa decl" ], + [ 0, qr{aaa.*\n\s*;\s*\n\#line 8 }, "correct #line" ], + ], + [ + "PPCODE trailing keyword", + Q(<<'EOF'), + |void + |foo(int aaa) + | PPCODE: + | YYY + | OUTPUT: + | blah +EOF + [ERR, qr{Error: PPCODE must be the last thing}, "got expected err" ], + ], + [ + "PPCODE code tweaks", + Q(<<'EOF'), + |void + |foo(int aaa) + | PPCODE: + | YYY +EOF + [ 0, qr{\QPERL_UNUSED_VAR(ax);}, "got PERL_UNUSED_VAR" ], + [ 0, qr{\QSP -= items;}, "got SP -= items" ], + [NOT, qr{\QXSRETURN}, "no XSRETURN" ], + [ 0, qr{\bPUTBACK\b.*\breturn\b}s, "got PUTBACK and return" ], + ], + + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +{ + # Test PREINIT: keyword + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | +EOF + + my @test_fns = ( + [ + "PREINIT basic", + Q(<<'EOF'), + |void + |foo(aaa, bbb) + | int aaa + | PREINIT: + | XXX + | YYY + | INPUT: + | short bbb + | CODE: + | ZZZ +EOF + [ 0, qr{\bint\s+aaa}, "has aaa decl" ], + [ 0, qr{^\s+XXX\n\s+YYY\n}m, "has XXX, YYY" ], + [ 0, qr{\bshort\s+bbb}, "has bbb decl" ], + [ 0, qr{^\s+ZZZ\n}m, "has ZZZ" ], + [ 0, qr{int\s+aaa.*XXX.*YYY.*bbb.*ZZZ}s,"in sequence" ], + ], + + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +{ + # Test XSUB-scoped SCOPE keyword + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | + |TYPEMAP: <catdir(qw(t lib)) : 'lib'); + +# Private test utilities +use TestMany; + +require_ok( 'ExtUtils::ParseXS' ); + +# Borrow the useful heredoc quoting/indenting function. +*Q = \&ExtUtils::ParseXS::Q; + +chdir('t') if -d 't'; +push @INC, '.'; + +package ExtUtils::ParseXS; +our $DIE_ON_ERROR = 1; +our $AUTHOR_WARNINGS = 1; +package main; + + +{ + # Test for C++ XSUB support: in particular, + # - an XSUB function including a class in its name implies C++ + # - implicit CLASS/THIS first arg + # - new and DESTROY methods handled specially + # - 'static' return type implies class method + # - 'const' can follow signature + # + + my $preamble = Q(<<'EOF'); + |MODULE = Foo PACKAGE = Foo + | + |PROTOTYPES: DISABLE + | + |TYPEMAP: <fff(bbb)/, "autocall" ], + ], + + [ + "C++: ggg", + Q(<<'EOF'), + |static int + |X::Y::ggg(int ccc) +EOF + [ 0, qr/usage\(cv,\s+"CLASS, ccc"\)/, "usage" ], + [ 0, qr/char\s*\*\s*CLASS\b/, "var decl" ], + [ 0, qr/\QX::Y::ggg(ccc)/, "autocall" ], + ], + + [ + "C++: hhh", + Q(<<'EOF'), + |int + |X::Y::hhh(int ddd) const +EOF + [ 0, qr/usage\(cv,\s+"THIS, ddd"\)/, "usage" ], + [ 0, qr/const X__Y\s*\*\s*THIS\s*=\s*my_in/, "var decl" ], + [ 0, qr/\QTHIS->hhh(ddd)/, "autocall" ], + ], + + [ + "C++: only const", + Q(<<'EOF'), + |void + |foo() const +EOF + [ERR, qr/\QError: const modifier only allowed on XSUBs which are C++ methods/, + "got expected err" ], + ], + + # autocall variants with const + + [ + "C++: static const", + Q(<<'EOF'), + |static int + |X::Y::foo() const +EOF + [ 0, qr/\QRETVAL = X::Y::foo()/, + "autocall doesn't have const" ], + ], + + [ + "C++: static new const", + Q(<<'EOF'), + |static int + |X::Y::new() const +EOF + [ 0, qr/\QRETVAL = X::Y()/, + "autocall doesn't have const" ], + ], + + [ + "C++: const", + Q(<<'EOF'), + |int + |X::Y::foo() const +EOF + [ 0, qr/\QRETVAL = THIS->foo()/, + "autocall doesn't have const" ], + ], + + [ + "C++: new const", + Q(<<'EOF'), + |int + |X::Y::new() const +EOF + [ 0, qr/\QRETVAL = new X::Y()/, + "autocall doesn't have const" ], + ], + + [ + "", + Q(<<'EOF'), + |int + |X::Y::f1(THIS, int i) +EOF + [ERR, qr/\QError: duplicate definition of parameter 'THIS' /, + "C++: f1 dup THIS" ], + ], + + [ + "", + Q(<<'EOF'), + |int + |X::Y::f2(int THIS, int i) +EOF + [ERR, qr/\QError: duplicate definition of parameter 'THIS' /, + "C++: f2 dup THIS" ], + ], + + [ + "", + Q(<<'EOF'), + |int + |X::Y::new(int CLASS, int i) +EOF + [ERR, qr/\QError: duplicate definition of parameter 'CLASS' /, + "C++: new dup CLASS" ], + ], + + [ + "C++: f3", + Q(<<'EOF'), + |int + |X::Y::f3(int i) + | OUTPUT: + | THIS +EOF + [ 0, qr/usage\(cv,\s+"THIS, i"\)/, "usage" ], + [ 0, qr/X__Y\s*\*\s*THIS\s*=\s*my_in/, "var decl" ], + [ 0, qr/\QTHIS->f3(i)/, "autocall" ], + [ 0, qr/^\s*\Qmy_out(ST(0), THIS)/m, "set st0" ], + ], + + [ + # allow THIS's type to be overridden ... + "C++: f4: override THIS type", + Q(<<'EOF'), + |int + |X::Y::f4(int i) + | int THIS +EOF + [ 0, qr/usage\(cv,\s+"THIS, i"\)/, "usage" ], + [ 0, qr/int\s*THIS\s*=\s*\(int\)/, "var decl" ], + [NOT, qr/X__Y\s*\*\s*THIS/, "no class var decl" ], + [ 0, qr/\QTHIS->f4(i)/, "autocall" ], + ], + + [ + # ... but not multiple times + "C++: f5: dup override THIS type", + Q(<<'EOF'), + |int + |X::Y::f5(int i) + | int THIS + | long THIS +EOF + [ERR, qr/\QError: duplicate definition of parameter 'THIS'/, + "dup err" ], + ], + + [ + # don't allow THIS in sig, with type + "C++: f6: sig THIS type", + Q(<<'EOF'), + |int + |X::Y::f6(int THIS) +EOF + [ERR, qr/\QError: duplicate definition of parameter 'THIS'/, + "dup err" ], + ], + + [ + # don't allow THIS in sig, without type + "C++: f7: sig THIS no type", + Q(<<'EOF'), + |int + |X::Y::f7(THIS) +EOF + [ERR, qr/\QError: duplicate definition of parameter 'THIS'/, + "dup err" ], + ], + + [ + # allow CLASS's type to be overridden ... + "C++: new: override CLASS type", + Q(<<'EOF'), + |int + |X::Y::new(int i) + | int CLASS +EOF + [ 0, qr/usage\(cv,\s+"CLASS, i"\)/, "usage" ], + [ 0, qr/int\s*CLASS\s*=\s*\(int\)/, "var decl" ], + [NOT, qr/char\s*\*\s*CLASS/, "no char* var decl" ], + [ 0, qr/\Qnew X::Y(i)/, "autocall" ], + ], + + [ + # ... but not multiple times + "C++: new dup override CLASS type", + Q(<<'EOF'), + |int + |X::Y::new(int i) + | int CLASS + | long CLASS +EOF + [ERR, qr/\QError: duplicate definition of parameter 'CLASS'/, + "dup err" ], + ], + + [ + # don't allow CLASS in sig, with type + "C++: new sig CLASS type", + Q(<<'EOF'), + |int + |X::Y::new(int CLASS) +EOF + [ERR, qr/\QError: duplicate definition of parameter 'CLASS'/, + "dup err" ], + ], + + [ + # don't allow CLASS in sig, without type + "C++: new sig CLASS no type", + Q(<<'EOF'), + |int + |X::Y::new(CLASS) +EOF + [ERR, qr/\QError: duplicate definition of parameter 'CLASS'/, + "dup err" ], + ], + + [ + "C++: DESTROY", + Q(<<'EOF'), + |void + |X::Y::DESTROY() +EOF + [ 0, qr/usage\(cv,\s+"THIS"\)/, "usage" ], + [ 0, qr/X__Y\s*\*\s*THIS\s*=\s*my_in/, "var decl" ], + [ 0, qr/delete\s+THIS;/, "autocall" ], + ] + ); + + test_many($preamble, 'XS_Foo_', \@test_fns); +} + + +done_testing; diff --git a/dist/ExtUtils-ParseXS/t/101-standard_typemap_locations.t b/dist/ExtUtils-ParseXS/t/101-api-standard_typemap_locations.t similarity index 97% rename from dist/ExtUtils-ParseXS/t/101-standard_typemap_locations.t rename to dist/ExtUtils-ParseXS/t/101-api-standard_typemap_locations.t index 32cefffc7398..4a1d1f799c93 100644 --- a/dist/ExtUtils-ParseXS/t/101-standard_typemap_locations.t +++ b/dist/ExtUtils-ParseXS/t/101-api-standard_typemap_locations.t @@ -1,4 +1,7 @@ #!/usr/bin/perl +# +# Test the standard_typemap_locations() function + use strict; use warnings; use Test::More tests => 5; diff --git a/dist/ExtUtils-ParseXS/t/102-trim_whitespace.t b/dist/ExtUtils-ParseXS/t/102-api-trim_whitespace.t similarity index 93% rename from dist/ExtUtils-ParseXS/t/102-trim_whitespace.t rename to dist/ExtUtils-ParseXS/t/102-api-trim_whitespace.t index 207b830fb3cb..ca519433302a 100644 --- a/dist/ExtUtils-ParseXS/t/102-trim_whitespace.t +++ b/dist/ExtUtils-ParseXS/t/102-api-trim_whitespace.t @@ -1,4 +1,7 @@ #!/usr/bin/perl +# +# Test the trim_whitespace() function + use strict; use warnings; use Test::More tests => 5; diff --git a/dist/ExtUtils-ParseXS/t/103-tidy_type.t b/dist/ExtUtils-ParseXS/t/103-api-tidy_type.t similarity index 94% rename from dist/ExtUtils-ParseXS/t/103-tidy_type.t rename to dist/ExtUtils-ParseXS/t/103-api-tidy_type.t index fc4e3c687942..3c1dbc8b97f2 100644 --- a/dist/ExtUtils-ParseXS/t/103-tidy_type.t +++ b/dist/ExtUtils-ParseXS/t/103-api-tidy_type.t @@ -1,4 +1,7 @@ #!/usr/bin/perl +# +# Test the tidy_type() function + use strict; use warnings; use Test::More; diff --git a/dist/ExtUtils-ParseXS/t/104-map_type.t b/dist/ExtUtils-ParseXS/t/104-api-map_type.t similarity index 98% rename from dist/ExtUtils-ParseXS/t/104-map_type.t rename to dist/ExtUtils-ParseXS/t/104-api-map_type.t index 38e9aec490bb..ec64f99e8c7e 100644 --- a/dist/ExtUtils-ParseXS/t/104-map_type.t +++ b/dist/ExtUtils-ParseXS/t/104-api-map_type.t @@ -1,4 +1,7 @@ #!/usr/bin/perl +# +# Test the map_type() function + use strict; use warnings; use Test::More tests => 7; diff --git a/dist/ExtUtils-ParseXS/t/105-valid_proto_string.t b/dist/ExtUtils-ParseXS/t/105-api-valid_proto_string.t similarity index 95% rename from dist/ExtUtils-ParseXS/t/105-valid_proto_string.t rename to dist/ExtUtils-ParseXS/t/105-api-valid_proto_string.t index e8a32a838751..e05e177f21ea 100644 --- a/dist/ExtUtils-ParseXS/t/105-valid_proto_string.t +++ b/dist/ExtUtils-ParseXS/t/105-api-valid_proto_string.t @@ -1,4 +1,7 @@ #!/usr/bin/perl +# +# Test the valid_proto_string() function + use strict; use warnings; use Test::More tests => 6; diff --git a/dist/ExtUtils-ParseXS/t/106-process_typemaps.t b/dist/ExtUtils-ParseXS/t/106-api-process_typemaps.t similarity index 93% rename from dist/ExtUtils-ParseXS/t/106-process_typemaps.t rename to dist/ExtUtils-ParseXS/t/106-api-process_typemaps.t index fab7a54867c1..23afaccbc7e2 100644 --- a/dist/ExtUtils-ParseXS/t/106-process_typemaps.t +++ b/dist/ExtUtils-ParseXS/t/106-api-process_typemaps.t @@ -1,4 +1,7 @@ #!/usr/bin/perl +# +# Test the process_typemaps() function + use strict; use warnings; use Carp; @@ -47,7 +50,7 @@ my $startdir = cwd(); { my $tm_obj = process_typemaps( - [ File::Spec->catfile("t", "data", "conflicting.typemap") ], '.'); + [ File::Spec->catfile("t", "test_typemaps", "conflicting.typemap") ], '.'); ok($tm_obj, "got typemap object"); my $tm_entry = $tm_obj->get_typemap(ctype => 'double'); diff --git a/dist/ExtUtils-ParseXS/t/108-map_type.t b/dist/ExtUtils-ParseXS/t/108-map_type.t deleted file mode 100644 index 3f2823ae453b..000000000000 --- a/dist/ExtUtils-ParseXS/t/108-map_type.t +++ /dev/null @@ -1,13 +0,0 @@ -#!/usr/bin/perl -use strict; -use warnings; -use Test::More qw(no_plan); # tests => 7; -use ExtUtils::ParseXS::Utilities qw( - map_type -); - -#print "\t" . map_type($self->{ret_type}, 'RETVAL', $self->{hiertype}) . ";\n" -#print "\t" . map_type($var_type, $var_name, $self->{hiertype}); -#print "\t" . map_type($var_type, undef, $self->{hiertype}); - -pass("Passed all tests in $0"); diff --git a/dist/ExtUtils-ParseXS/t/112-set_cond.t b/dist/ExtUtils-ParseXS/t/112-set_cond.t deleted file mode 100644 index 2a3a70fc4ddd..000000000000 --- a/dist/ExtUtils-ParseXS/t/112-set_cond.t +++ /dev/null @@ -1,9 +0,0 @@ -#!/usr/bin/perl -use strict; -use warnings; -use Test::More qw(no_plan); # tests => 7; -use ExtUtils::ParseXS::Utilities qw( - set_cond -); - -pass("Passed all tests in $0"); diff --git a/dist/ExtUtils-ParseXS/t/113-check_cond_preproc_statements.t b/dist/ExtUtils-ParseXS/t/113-api-check_cond_preproc_statements.t similarity index 98% rename from dist/ExtUtils-ParseXS/t/113-check_cond_preproc_statements.t rename to dist/ExtUtils-ParseXS/t/113-api-check_cond_preproc_statements.t index 9b4a18f22e99..cb02527d70c3 100644 --- a/dist/ExtUtils-ParseXS/t/113-check_cond_preproc_statements.t +++ b/dist/ExtUtils-ParseXS/t/113-api-check_cond_preproc_statements.t @@ -1,4 +1,7 @@ #!/usr/bin/perl +# +# Test the check_conditional_preprocessor_statements() function + use strict; use warnings; use File::Spec; diff --git a/dist/ExtUtils-ParseXS/t/114-blurt_death_Warn.t b/dist/ExtUtils-ParseXS/t/114-api-blurt_death_Warn.t similarity index 75% rename from dist/ExtUtils-ParseXS/t/114-blurt_death_Warn.t rename to dist/ExtUtils-ParseXS/t/114-api-blurt_death_Warn.t index 3e44dc685187..a4a7b9dc8ad8 100644 --- a/dist/ExtUtils-ParseXS/t/114-blurt_death_Warn.t +++ b/dist/ExtUtils-ParseXS/t/114-api-blurt_death_Warn.t @@ -1,8 +1,11 @@ #!/usr/bin/perl +# +# Test the Warn, death() etc methods themselves. + use strict; use warnings; $| = 1; -use Test::More tests => 7; +use Test::More tests => 8; use File::Spec; use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib'); use ExtUtils::ParseXS; @@ -102,8 +105,7 @@ $self->{line_no} = []; is( $self->report_error_count, 1, "Error count incremented correctly" ); } -SKIP: { - skip "death() not testable as long as it contains hard-coded 'exit'", 1; +{ $self->{line} = [ 'Alpha', @@ -114,16 +116,24 @@ SKIP: { $self->{line_no} = [ 17 .. 20 ]; $self->{in_filename} = 'myfile1'; - my $message = "Code is not inside a function"; - eval { - my $stderr = PrimitiveCapture::capture_stderr(sub { - death( $self, $message); - }); - like( $stderr, - qr/$message in $self->{in_filename}, line 20/, - "Got expected death output", - ); - }; + my $message = "reports of my death are premature"; + my ($stderr, $err); + $stderr = PrimitiveCapture::capture_stderr(sub { + # NB: can't use 'local' here because under 5.8.x, $self is a + # pseudo hash and trying to localise gives this error: + # Can't localize pseudo-hash element + my $old = $self->{config_die_on_error}; + $self->{config_die_on_error} = 1; # don't exit + eval { death( $self, $message); }; + $err = $@; + $self->{config_die_on_error} = $old; + }); + like( $err, + qr/$message in $self->{in_filename}, line 20/, + "Got expected death output", + ); + is($stderr, undef, "no stderr noise in death", + ); } pass("Passed all tests in $0"); diff --git a/dist/ExtUtils-ParseXS/t/115-avoid-noise.t b/dist/ExtUtils-ParseXS/t/115-avoid-noise.t deleted file mode 100644 index b3bbe6177a54..000000000000 --- a/dist/ExtUtils-ParseXS/t/115-avoid-noise.t +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/perl -w -use strict; -use warnings; -use File::Spec; -use Test::More tests => 1; -use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib'); -use ExtUtils::ParseXS qw(process_file); - -chdir('t') if -d 't'; - -# Module-Build uses ExtUtils::ParseXS with $^W set, try to avoid -# warning in that case. - -{ - my $out; - open my $out_fh, ">", \$out; - my @warnings; - local $SIG{__WARN__} = sub { push @warnings, "@_" }; - process_file(filename => "XSWarn.xs", output => $out_fh); - is_deeply(\@warnings, [], "shouldn't be any warnings"); -} diff --git a/dist/ExtUtils-ParseXS/t/301-run-basic.t b/dist/ExtUtils-ParseXS/t/301-run-basic.t new file mode 100644 index 000000000000..c4cf34fc3a9a --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/301-run-basic.t @@ -0,0 +1,213 @@ +#!/usr/bin/perl +# +# 301-run-basic.t: +# +# Pass the file XSTest.xs through the XS parser and then through the C +# compiler. Then execute the resulting object file. +# +# In general, tests which only need to examine whether the XS parser +# has created the right C snippets should be added to the 0xx-parse-foo.t +# test files. Only add tests here which need to be actually executed. +# +# Tests in the 3xx-run-foo.t namespace always run a C compiler + +use strict; +use warnings; +use Test::More; +use Config; +use DynaLoader; +use ExtUtils::CBuilder; +use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib'); +use PrimitiveCapture; + +my ($source_file, $obj_file, $lib_file); + +require_ok( 'ExtUtils::ParseXS' ); + +{ + # Minimal tie package to capture output to a filehandle + package Capture; + sub TIEHANDLE { bless {} } + sub PRINT { shift->{buf} .= join '', @_ } + sub PRINTF { my $obj = shift; my $fmt = shift; + $obj->{buf} .= sprintf $fmt, @_ } + sub content { shift->{buf} } +} + +chdir('t') if -d 't'; +push @INC, '.'; + +package ExtUtils::ParseXS; +our $DIE_ON_ERROR = 1; +our $AUTHOR_WARNINGS = 1; +package main; + +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 +# refuse to load relative paths. The path that DynaLoader uses to load the +# .so or .bundle file is based on the @INC path that the library is loaded +# from. The XSTest module we're using for testing is in the current directory, +# so we need an absolute path in @INC rather than '.'. Just convert all of the +# paths to absolute for simplicity. + + +######################### + + +{ # first block: try without linenumbers +my $pxs = ExtUtils::ParseXS->new; +# Try sending to filehandle +tie *FH, 'Capture'; +$pxs->process_file( filename => 'XSTest.xs', output => \*FH, prototypes => 1 ); +like tied(*FH)->content, '/is_even/', "Test that output contains some text"; + +$source_file = 'XSTest.c'; + +# Try sending to file +$pxs->process_file(filename => 'XSTest.xs', output => $source_file, prototypes => 0); +ok -e $source_file, "Create an output file"; + +my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE}; +my $b = ExtUtils::CBuilder->new(quiet => $quiet); + +SKIP: { + skip "no compiler available", 2 + if ! $b->have_compiler; + $obj_file = $b->compile( source => $source_file ); + ok $obj_file, "ExtUtils::CBuilder::compile() returned true value"; + ok -e $obj_file, "Make sure $obj_file exists"; +} + +SKIP: { + skip "no dynamic loading", 5 + if !$b->have_compiler || !$Config{usedl}; + my $module = 'XSTest'; + $lib_file = $b->link( objects => $obj_file, module_name => $module ); + ok $lib_file, "ExtUtils::CBuilder::link() returned true value"; + ok -e $lib_file, "Make sure $lib_file exists"; + + eval {require XSTest}; + is $@, '', "No error message recorded, as expected"; + ok XSTest::is_even(8), + "Function created thru XS returned expected true value"; + ok !XSTest::is_even(9), + "Function created thru XS returned expected false value"; + + # Win32 needs to close the DLL before it can unlink it, but unfortunately + # dl_unload_file was missing on Win32 prior to perl change #24679! + if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) { + for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) { + if ($DynaLoader::dl_modules[$i] eq $module) { + DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]); + last; + } + } + } +} + +my $seen = 0; +open my $IN, '<', $source_file + or die "Unable to open $source_file: $!"; +while (my $l = <$IN>) { + $seen++ if $l =~ m/#line\s1\s/; +} +is( $seen, 1, "Line numbers created in output file, as intended" ); +{ + #rewind .c file and regexp it to look for code generation problems + 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 +.+? +#line \d+\Q "XSTest.c" + ST(0) = boolSV(RETVAL); + } + XSRETURN(1); +} +\E|s; + like($filecontents, $good_T_BOOL_re, "T_BOOL doesn\'t have an extra sv_newmortal or sv_2mortal"); + + my $good_T_BOOL_2_re = +qr|\QXS_EUPXS(XS_XSTest_T_BOOL_2)\E +.+? +#line \d+\Q "XSTest.c" + sv_setsv(ST(0), boolSV(in)); + SvSETMAGIC(ST(0)); + } + XSRETURN(1); +} +\E|s; + like($filecontents, $good_T_BOOL_2_re, 'T_BOOL_2 doesn\'t have an extra sv_newmortal or sv_2mortal'); + my $good_T_BOOL_OUT_re = +qr|\QXS_EUPXS(XS_XSTest_T_BOOL_OUT)\E +.+? +#line \d+\Q "XSTest.c" + sv_setsv(ST(0), boolSV(out)); + SvSETMAGIC(ST(0)); + } + XSRETURN_EMPTY; +} +\E|s; + like($filecontents, $good_T_BOOL_OUT_re, 'T_BOOL_OUT doesn\'t have an extra sv_newmortal or sv_2mortal'); + +} +close $IN or die "Unable to close $source_file: $!"; + +unless ($ENV{PERL_NO_CLEANUP}) { + for ( $obj_file, $lib_file, $source_file) { + next unless defined $_; + 1 while unlink $_; + } +} +} + +##################################################################### + +{ # second block: try with linenumbers +my $pxs = ExtUtils::ParseXS->new; +# Try sending to filehandle +tie *FH, 'Capture'; +$pxs->process_file( + filename => 'XSTest.xs', + output => \*FH, + prototypes => 1, + linenumbers => 0, +); +like tied(*FH)->content, '/is_even/', "Test that output contains some text"; + +$source_file = 'XSTest.c'; + +# Try sending to file +$pxs->process_file( + filename => 'XSTest.xs', + output => $source_file, + prototypes => 0, + linenumbers => 0, +); +ok -e $source_file, "Create an output file"; + + +my $seen = 0; +open my $IN, '<', $source_file + or die "Unable to open $source_file: $!"; +while (my $l = <$IN>) { + $seen++ if $l =~ m/#line\s1\s/; +} +close $IN or die "Unable to close $source_file: $!"; +is( $seen, 0, "No linenumbers created in output file, as intended" ); + +unless ($ENV{PERL_NO_CLEANUP}) { + for ( $obj_file, $lib_file, $source_file) { + next unless defined $_; + 1 while unlink $_; + } +} +} +##################################################################### + +done_testing; + diff --git a/dist/ExtUtils-ParseXS/t/002-more.t b/dist/ExtUtils-ParseXS/t/302-run-more.t similarity index 89% rename from dist/ExtUtils-ParseXS/t/002-more.t rename to dist/ExtUtils-ParseXS/t/302-run-more.t index 0dc134c1f627..ed9c1e6e47ee 100644 --- a/dist/ExtUtils-ParseXS/t/002-more.t +++ b/dist/ExtUtils-ParseXS/t/302-run-more.t @@ -1,4 +1,15 @@ #!/usr/bin/perl +# +# 302-run-more.t: +# +# Pass the file XSMore.xs through the XS parser and then through the C +# compiler. Then execute the resulting object file. +# +# In general, tests which only need to examine whether the XS parser +# has created the right C snippets should be added to the 0xx-parse-foo.t +# test files. Only add tests here which need to be actually executed. +# +# Tests in the 3xx-run-foo.t namespace always run a C compiler use strict; use warnings; @@ -21,7 +32,7 @@ push @INC, '.'; use Carp; #$SIG{__WARN__} = \&Carp::cluck; -# See the comments about this in 001-basics.t +# See the comments about this in 301-run-basics.t @INC = map { File::Spec->rel2abs($_) } @INC; ######################### diff --git a/dist/ExtUtils-ParseXS/t/003-usage.t b/dist/ExtUtils-ParseXS/t/303-run-usage.t similarity index 84% rename from dist/ExtUtils-ParseXS/t/003-usage.t rename to dist/ExtUtils-ParseXS/t/303-run-usage.t index f33e3e0d9c17..7aa8ceff9bf9 100644 --- a/dist/ExtUtils-ParseXS/t/003-usage.t +++ b/dist/ExtUtils-ParseXS/t/303-run-usage.t @@ -1,4 +1,15 @@ #!/usr/bin/perl +# +# 303-run-usage.t: +# +# Pass the file XSUsage.xs through the XS parser and then through the C +# compiler. Then execute the resulting object file. +# +# In general, tests which only need to examine whether the XS parser +# has created the right C snippets should be added to the 0xx-parse-foo.t +# test files. Only add tests here which need to be actually executed. +# +# Tests in the 3xx-run-foo.t namespace always run a C compiler use strict; use Test::More; @@ -22,7 +33,7 @@ push @INC, '.'; use Carp; #$SIG{__WARN__} = \&Carp::cluck; -# See the comments about this in 001-basics.t +# See the comments about this in 301-run-basics.t @INC = map { File::Spec->rel2abs($_) } @INC; ######################### diff --git a/dist/ExtUtils-ParseXS/t/501-t-compile.t b/dist/ExtUtils-ParseXS/t/501-typemaps-compile.t similarity index 81% rename from dist/ExtUtils-ParseXS/t/501-t-compile.t rename to dist/ExtUtils-ParseXS/t/501-typemaps-compile.t index 5681cd2e22e3..5aceadeda0ca 100644 --- a/dist/ExtUtils-ParseXS/t/501-t-compile.t +++ b/dist/ExtUtils-ParseXS/t/501-typemaps-compile.t @@ -1,4 +1,8 @@ #!/usr/bin/perl +# +# Test ExtUtils::Typemaps: +# check it built ok. + use strict; BEGIN { $| = 1; diff --git a/dist/ExtUtils-ParseXS/t/510-t-bare.t b/dist/ExtUtils-ParseXS/t/510-typemaps-bare.t similarity index 98% rename from dist/ExtUtils-ParseXS/t/510-t-bare.t rename to dist/ExtUtils-ParseXS/t/510-typemaps-bare.t index 033c0aea5a3e..7a292f1764d8 100644 --- a/dist/ExtUtils-ParseXS/t/510-t-bare.t +++ b/dist/ExtUtils-ParseXS/t/510-typemaps-bare.t @@ -1,4 +1,8 @@ #!/usr/bin/perl +# +# Test ExtUtils::Typemaps: +# [ XXX I'm not clear what 'bare' refers to in the test file name ] + use strict; use warnings; diff --git a/dist/ExtUtils-ParseXS/t/511-t-whitespace.t b/dist/ExtUtils-ParseXS/t/511-typemaps-whitespace.t similarity index 89% rename from dist/ExtUtils-ParseXS/t/511-t-whitespace.t rename to dist/ExtUtils-ParseXS/t/511-typemaps-whitespace.t index 003d7e5378ca..cd064f5572b5 100644 --- a/dist/ExtUtils-ParseXS/t/511-t-whitespace.t +++ b/dist/ExtUtils-ParseXS/t/511-typemaps-whitespace.t @@ -1,4 +1,8 @@ #!/usr/bin/perl +# +# Test ExtUtils::Typemaps: +# Check that leading white space in typemap lines are handled correctly. + use strict; use warnings; diff --git a/dist/ExtUtils-ParseXS/t/512-t-file.t b/dist/ExtUtils-ParseXS/t/512-typemaps-file.t similarity index 90% rename from dist/ExtUtils-ParseXS/t/512-t-file.t rename to dist/ExtUtils-ParseXS/t/512-typemaps-file.t index 53bb393738ba..417f77eb8eeb 100644 --- a/dist/ExtUtils-ParseXS/t/512-t-file.t +++ b/dist/ExtUtils-ParseXS/t/512-typemaps-file.t @@ -1,4 +1,8 @@ #!/usr/bin/perl +# +# Test ExtUtils::Typemaps: +# check creating and writing typemaps + use strict; use warnings; @@ -7,7 +11,8 @@ use ExtUtils::Typemaps; use File::Spec; use File::Temp; -my $datadir = -d 't' ? File::Spec->catdir(qw/t data/) : 'data'; +my $datadir = -d 't' ? File::Spec->catdir(qw/t test_typemaps/) + : 'test_typemaps'; sub slurp { my $file = shift; diff --git a/dist/ExtUtils-ParseXS/t/513-t-merge.t b/dist/ExtUtils-ParseXS/t/513-typemaps-merge.t similarity index 96% rename from dist/ExtUtils-ParseXS/t/513-t-merge.t rename to dist/ExtUtils-ParseXS/t/513-typemaps-merge.t index 72d948fce2a8..546b97318ae5 100644 --- a/dist/ExtUtils-ParseXS/t/513-t-merge.t +++ b/dist/ExtUtils-ParseXS/t/513-typemaps-merge.t @@ -1,4 +1,7 @@ #!/usr/bin/perl +# +# Test ExtUtils::Typemaps::merge() + use strict; use warnings; @@ -7,7 +10,8 @@ use ExtUtils::Typemaps; use File::Spec; use File::Temp; -my $datadir = -d 't' ? File::Spec->catdir(qw/t data/) : 'data'; +my $datadir = -d 't' ? File::Spec->catdir(qw/t test_typemaps/) + : 'test_typemaps'; sub slurp { my $file = shift; diff --git a/dist/ExtUtils-ParseXS/t/514-t-embed.t b/dist/ExtUtils-ParseXS/t/514-typemaps-embed.t similarity index 87% rename from dist/ExtUtils-ParseXS/t/514-t-embed.t rename to dist/ExtUtils-ParseXS/t/514-typemaps-embed.t index 976af3123e96..01b5b5e2af3d 100644 --- a/dist/ExtUtils-ParseXS/t/514-t-embed.t +++ b/dist/ExtUtils-ParseXS/t/514-typemaps-embed.t @@ -1,4 +1,7 @@ #!/usr/bin/perl +# +# Test ExtUtils::Typemaps::as_embedded_typemap() + use strict; use warnings; diff --git a/dist/ExtUtils-ParseXS/t/515-t-cmd.t b/dist/ExtUtils-ParseXS/t/515-typemaps-cmd.t similarity index 92% rename from dist/ExtUtils-ParseXS/t/515-t-cmd.t rename to dist/ExtUtils-ParseXS/t/515-typemaps-cmd.t index d5e862b7e65c..c811cafd98d9 100644 --- a/dist/ExtUtils-ParseXS/t/515-t-cmd.t +++ b/dist/ExtUtils-ParseXS/t/515-typemaps-cmd.t @@ -1,4 +1,7 @@ #!/usr/bin/perl +# +# Test ExtUtils::Typemaps::Cmd::embeddable_typemap() + use strict; use warnings; @@ -8,7 +11,8 @@ use Test::More tests => 6; use File::Spec; use ExtUtils::Typemaps::Cmd; -my $datadir = -d 't' ? File::Spec->catdir(qw/t data/) : 'data'; +my $datadir = -d 't' ? File::Spec->catdir(qw/t test_typemaps/) + : 'test_typemaps'; my $libdir = -d 't' ? File::Spec->catdir(qw/t lib/) : 'lib'; unshift @INC, $libdir; diff --git a/dist/ExtUtils-ParseXS/t/516-t-clone.t b/dist/ExtUtils-ParseXS/t/516-typemaps-clone.t similarity index 97% rename from dist/ExtUtils-ParseXS/t/516-t-clone.t rename to dist/ExtUtils-ParseXS/t/516-typemaps-clone.t index 239ec52e9667..7edf8e527d5e 100644 --- a/dist/ExtUtils-ParseXS/t/516-t-clone.t +++ b/dist/ExtUtils-ParseXS/t/516-typemaps-clone.t @@ -1,4 +1,7 @@ #!/usr/bin/perl +# +# Test ExtUtils::Typemaps::clone() + use strict; use warnings; diff --git a/dist/ExtUtils-ParseXS/t/517-t-targetable.t b/dist/ExtUtils-ParseXS/t/517-typemaps-targetable.t similarity index 98% rename from dist/ExtUtils-ParseXS/t/517-t-targetable.t rename to dist/ExtUtils-ParseXS/t/517-typemaps-targetable.t index 81ee99adf65d..3677e74ff160 100644 --- a/dist/ExtUtils-ParseXS/t/517-t-targetable.t +++ b/dist/ExtUtils-ParseXS/t/517-typemaps-targetable.t @@ -1,4 +1,8 @@ #!/usr/bin/perl +# +# Test ExtUtils::Typemaps: +# test targetable() and targetable_legacy() methods + use strict; use warnings; use Carp; diff --git a/dist/ExtUtils-ParseXS/t/600-t-compat.t b/dist/ExtUtils-ParseXS/t/518-typemaps-compat.t similarity index 95% rename from dist/ExtUtils-ParseXS/t/600-t-compat.t rename to dist/ExtUtils-ParseXS/t/518-typemaps-compat.t index 6a330668d2d1..4cb0f2e1b5ab 100644 --- a/dist/ExtUtils-ParseXS/t/600-t-compat.t +++ b/dist/ExtUtils-ParseXS/t/518-typemaps-compat.t @@ -1,13 +1,16 @@ #!/usr/bin/perl +# +# Test ExtUtils::Typemaps: +# +# This test file is for making sure that the new EU::Typemaps +# based typemap merging produces the same result as the old +# EU::ParseXS code. + use strict; use warnings; use Test::More; -# This test is for making sure that the new EU::Typemaps -# based typemap merging produces the same result as the old -# EU::ParseXS code. - use ExtUtils::Typemaps; use ExtUtils::ParseXS::Utilities qw( C_string @@ -17,7 +20,8 @@ use ExtUtils::ParseXS::Utilities qw( use ExtUtils::ParseXS::Constants; use File::Spec; -my $path_prefix = File::Spec->catdir(-d 't' ? qw(t data) : qw(data)); +my $path_prefix = File::Spec->catdir(-d 't' ? qw(t test_typemaps) + : qw(test_typemaps)); my @tests = ( { diff --git a/dist/ExtUtils-ParseXS/t/XSAlias.xs b/dist/ExtUtils-ParseXS/t/XSAlias.xs deleted file mode 100644 index df4c1003d3de..000000000000 --- a/dist/ExtUtils-ParseXS/t/XSAlias.xs +++ /dev/null @@ -1,21 +0,0 @@ -MODULE = My PACKAGE = My - -void -do(dbh) - SV *dbh -ALIAS: - dox = 1 - lox => dox - pox = 1 - pox = 2 - docks = 1 - dachs => lox - xunx = 0 - do = 0 - xunx2 = 0 - xukes => do -CODE: -{ - int x; - ++x; -} diff --git a/dist/ExtUtils-ParseXS/t/XSBroken.xs b/dist/ExtUtils-ParseXS/t/XSBroken.xs deleted file mode 100644 index 791383820f0b..000000000000 --- a/dist/ExtUtils-ParseXS/t/XSBroken.xs +++ /dev/null @@ -1,26 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -typedef IV MyType3; - -MODULE = XSBroken PACKAGE = XSBroken - -PROTOTYPES: ENABLE - - -TYPEMAP: <<'END' -MyType3 T_BAAR - -OUTPUT -T_BAAR - sv_setiv($arg, (IV)$var); -END - -MyType3 -typemaptest3(foo) - MyType3 foo - CODE: - RETVAL = foo; - OUTPUT: - RETVAL diff --git a/dist/ExtUtils-ParseXS/t/XSFalsePositive.xs b/dist/ExtUtils-ParseXS/t/XSFalsePositive.xs deleted file mode 100644 index 87a9330ab09c..000000000000 --- a/dist/ExtUtils-ParseXS/t/XSFalsePositive.xs +++ /dev/null @@ -1,23 +0,0 @@ -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/dist/ExtUtils-ParseXS/t/XSFalsePositive2.xs b/dist/ExtUtils-ParseXS/t/XSFalsePositive2.xs deleted file mode 100644 index 4e0ca7e1a8c2..000000000000 --- a/dist/ExtUtils-ParseXS/t/XSFalsePositive2.xs +++ /dev/null @@ -1,23 +0,0 @@ -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/dist/ExtUtils-ParseXS/t/XSNoMap.xs b/dist/ExtUtils-ParseXS/t/XSNoMap.xs deleted file mode 100644 index 9878635fdb5d..000000000000 --- a/dist/ExtUtils-ParseXS/t/XSNoMap.xs +++ /dev/null @@ -1,9 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -MODULE = XSNoMap PACKAGE = XSNoMap PREFIX = xsnomap_ - -PROTOTYPES: DISABLE - -TYPEMAP: <catdir(qw(t lib)) : 'lib'); + +# Private test utilities +use PrimitiveCapture; + +# DIY Exporter +{ + my $callpkg = caller(0); + for (qw(test_many NOT ERR TODO)) { + no strict 'refs'; + *{"$callpkg\::$_"} = \&{__PACKAGE__ . "\::$_"}; + } +} + +{ + # Minimal tie package to capture output to a filehandle + package Capture; + sub TIEHANDLE { bless {} } + sub PRINT { shift->{buf} .= join '', @_ } + sub PRINTF { my $obj = shift; my $fmt = shift; + $obj->{buf} .= sprintf $fmt, @_ } + sub content { shift->{buf} } +} + + +######################################################################### + +# test_many(): a framework for running XS parser tests. +# +# It runs a series of pattern tests on the C output generated by one or +# more XS code snippets which share a common preamble. The input XS and +# output C are stored in strings rather than accessing physical *.xs and +# .c files. +# +# Its arguments are: +# +# $preamble A multi-line string which is prepended to each XS test +# item before being parsed. It typically has MODULE and +# PROTOTYPES lines and sometimes a TYPEMAP block. +# +# $extract_prefix Specify a prefix of the name of the C XSUB to be +# extracted out and used in subsequent pattern matches +# and in "got vs expected" diagnostics. For example a +# foo XSUB in package Foo::Bar will have the C name +# XS_Foo__Bar_foo, so a prefix of 'XS_Foo__Bar_' will +# extract any XSUB declared in the Foo::Bar package. +# Similarly, boot_Foo__Bar will extract the boot XSUB +# for that package. If undef, the whole C file will be +# used for matching and in error messages. +# +# $test_fns An array ref of tests to run; see below. +# +# $options An optional array ref of option key/value pairs +# to be passed as extra parameters to the +# process_file() method call, e.g. [ inout => 1 ] +# +# Each element in the $test_fns array ref is an array ref containing +# some XS code and a series of pattern match tests to run against the +# result: +# +# [ +# "common prefix for test descriptions", +# "lines to be used\n as the XS test code\n", +# +# [ flags, qr/expected/, "test description" (, "TODO text")], +# +# [ ... and more tests ..], +# +# .... +# ] +# +# where flags is zero or more of: +# +# NOT: invert: pass if the regex *doesn't* match +# ERR: test regex against STDERR and $@ rather than STDOUT +# TODO: mark the test as TODO. If set, an optional extra field +# may be included, which is the TODO description. + + +# (avoid 'use constant' as an extra build-time dependency) +sub NOT() { 1; } +sub ERR() { 2; } +sub TODO() { 4; } + +sub test_many { + my ($preamble, $extract_prefix, $test_fns, $options) = @_; + $options = [] unless $options; + + for my $test_fn (@$test_fns) { + my ($desc_prefix, $xsub_lines, @tests) = @$test_fn; + + my $text = $preamble . $xsub_lines; + + tie *FH, 'Capture'; + my $pxs = ExtUtils::ParseXS->new; + my $err; + my $stderr = PrimitiveCapture::capture_stderr(sub { + eval { + $pxs->process_file( filename => \$text, output => \*FH, + @$options); + }; + $err = $@; + }); + if (defined $err and length $err) { + $stderr = "" unless defined $stderr; + $stderr = $err . $stderr; + } + + my $out = tied(*FH)->content; + untie *FH; + + # trim the output to just the function in question to make + # test diagnostics smaller. + if (defined($extract_prefix) and !length($err) and $out =~ /\S/) { + $out =~ s/\A.*? (^\w+\(${extract_prefix} .*? ^}).*\z/$1/xms + or do { + # print STDERR $out; + die "$desc_prefix: couldn't trim output to only function starting '$extract_prefix'\n"; + } + } + + my $err_tested; + for my $test (@tests) { + my ($flags, $qr, $desc, $todo) = @$test; + $desc = "$desc_prefix: $desc" if length $desc_prefix; + my $str; + + if ($flags & TODO) { + $todo = '' unless defined $todo; + } + elsif (defined $todo) { + die "$desc_prefix: Internal error:" + . " todo text present but not TODO flag\n"; + } + + if ($flags & ERR) { + $err_tested = 1; + $str = $stderr; + } + else { + $str = $out; + } + local $TODO = $todo if $flags & TODO; + + if ($flags & NOT) { + unlike $str, $qr, $desc; + } + else { + like $str, $qr, $desc; + } + + } + # if there were no tests that expect an error, test that there + # were no errors + if (!$err_tested) { + is $stderr, undef, "$desc_prefix: no errors expected"; + } + } +} + + + +1; diff --git a/dist/ExtUtils-ParseXS/t/pseudotypemap1 b/dist/ExtUtils-ParseXS/t/pseudotypemap1 deleted file mode 100644 index de771bd279c1..000000000000 --- a/dist/ExtUtils-ParseXS/t/pseudotypemap1 +++ /dev/null @@ -1,5 +0,0 @@ - # pseudotypemap1: comment with leading whitespace -TYPEMAP - -line_to_generate_insufficient_columns_warning -unsigned long T_UV diff --git a/dist/ExtUtils-ParseXS/t/data/b.typemap b/dist/ExtUtils-ParseXS/t/test_typemaps/b.typemap similarity index 100% rename from dist/ExtUtils-ParseXS/t/data/b.typemap rename to dist/ExtUtils-ParseXS/t/test_typemaps/b.typemap diff --git a/dist/ExtUtils-ParseXS/t/data/combined.typemap b/dist/ExtUtils-ParseXS/t/test_typemaps/combined.typemap similarity index 100% rename from dist/ExtUtils-ParseXS/t/data/combined.typemap rename to dist/ExtUtils-ParseXS/t/test_typemaps/combined.typemap diff --git a/dist/ExtUtils-ParseXS/t/data/confl_repl.typemap b/dist/ExtUtils-ParseXS/t/test_typemaps/confl_repl.typemap similarity index 100% rename from dist/ExtUtils-ParseXS/t/data/confl_repl.typemap rename to dist/ExtUtils-ParseXS/t/test_typemaps/confl_repl.typemap diff --git a/dist/ExtUtils-ParseXS/t/data/confl_skip.typemap b/dist/ExtUtils-ParseXS/t/test_typemaps/confl_skip.typemap similarity index 100% rename from dist/ExtUtils-ParseXS/t/data/confl_skip.typemap rename to dist/ExtUtils-ParseXS/t/test_typemaps/confl_skip.typemap diff --git a/dist/ExtUtils-ParseXS/t/data/conflicting.typemap b/dist/ExtUtils-ParseXS/t/test_typemaps/conflicting.typemap similarity index 100% rename from dist/ExtUtils-ParseXS/t/data/conflicting.typemap rename to dist/ExtUtils-ParseXS/t/test_typemaps/conflicting.typemap diff --git a/dist/ExtUtils-ParseXS/t/data/other.typemap b/dist/ExtUtils-ParseXS/t/test_typemaps/other.typemap similarity index 100% rename from dist/ExtUtils-ParseXS/t/data/other.typemap rename to dist/ExtUtils-ParseXS/t/test_typemaps/other.typemap diff --git a/dist/ExtUtils-ParseXS/t/data/perl.typemap b/dist/ExtUtils-ParseXS/t/test_typemaps/perl.typemap similarity index 100% rename from dist/ExtUtils-ParseXS/t/data/perl.typemap rename to dist/ExtUtils-ParseXS/t/test_typemaps/perl.typemap diff --git a/dist/ExtUtils-ParseXS/t/data/simple.typemap b/dist/ExtUtils-ParseXS/t/test_typemaps/simple.typemap similarity index 100% rename from dist/ExtUtils-ParseXS/t/data/simple.typemap rename to dist/ExtUtils-ParseXS/t/test_typemaps/simple.typemap