dist/ExtUtils-ParseXS/t/108-map_type.t ExtUtils::ParseXS tests
dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t ExtUtils::ParseXS tests
dist/ExtUtils-ParseXS/t/110-assign_func_args.t ExtUtils::ParseXS tests
-dist/ExtUtils-ParseXS/t/111-print_preprocessor_statements.t ExtUtils::ParseXS tests
+dist/ExtUtils-ParseXS/t/111-analyze_preprocessor_statements.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/lib/IncludeTester.pm ExtUtils::ParseXS testing utility
+dist/ExtUtils-ParseXS/t/lib/PrimitiveCapture.pm Primitive STDOUT/ERR capturing for tests
dist/ExtUtils-ParseXS/t/pseudotypemap1 A test-typemap
dist/ExtUtils-ParseXS/t/typemap Standard typemap for controlled testing
dist/ExtUtils-ParseXS/t/XSInclude.xsh Test file for ExtUtils::ParseXS tests
map_type
standard_XS_defs
assign_func_args
- print_preprocessor_statements
+ analyze_preprocessor_statements
set_cond
Warn
blurt
my $ln = shift(@{ $self->{line} });
print $ln, "\n";
next unless $ln =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
+ my $statement = $+;
( $self, $XSS_work_idx, $BootCode_ref ) =
- print_preprocessor_statements( $self, $XSS_work_idx, $BootCode_ref );
+ analyze_preprocessor_statements(
+ $self, $statement, $XSS_work_idx, $BootCode_ref
+ );
}
next PARAGRAPH unless @{ $self->{line} };
}
else {
if ($self->{ret_type} ne "void") {
- print "\t" . map_type($self->{ret_type}, 'RETVAL', $self->{hiertype}) . ";\n"
+ print "\t" . map_type($self, $self->{ret_type}, 'RETVAL') . ";\n"
if !$self->{retvaldone};
$self->{args_match}->{"RETVAL"} = 0;
$self->{var_types}->{"RETVAL"} = $self->{ret_type};
my $printed_name;
if ($var_type =~ / \( \s* \* \s* \) /x) {
# Function pointers are not yet supported with &output_init!
- print "\t" . map_type($var_type, $var_name, $self->{hiertype});
+ print "\t" . map_type($self, $var_type, $var_name);
$printed_name = 1;
}
else {
- print "\t" . map_type($var_type, undef, $self->{hiertype});
+ print "\t" . map_type($self, $var_type, undef);
$printed_name = 0;
}
$self->{var_num} = $self->{args_match}->{$var_name};
map_type
standard_XS_defs
assign_func_args
- print_preprocessor_statements
+ analyze_preprocessor_statements
set_cond
Warn
blurt
return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
}
+=head2 C<process_single_typemap()>
+
+=over 4
+
+=item * Purpose
+
+Process a single typemap within C<process_typemaps()>.
+
+=item * Arguments
+
+ ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
+ process_single_typemap( $typemap,
+ $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
+
+List of five elements: The individual typemap needing processing and four
+references.
+
+=item * Return Value
+
+List of four references -- modified versions of those passed in as arguments.
+
+=back
+
+=cut
+
sub process_single_typemap {
my ($typemap,
$type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = @_;
$type_kind_ref->{$type} = $kind;
# prototype defaults to '$'
$proto = "\$" unless $proto;
-# warn(
-# "Warning: File '$typemap' Line $. '$logged_line' " .
-# "Invalid prototype '$proto'\n"
-# ) unless valid_proto_string($proto);
$proto_letter_ref->{$type} = C_string($proto);
}
elsif (/^\s/) {
return %targetable;
}
+=head2 C<map_type()>
+
+=over 4
+
+=item * Purpose
+
+Performs a mapping at several places inside C<PARAGRAPH> loop.
+
+=item * Arguments
+
+ $type = map_type($self, $type, $varname);
+
+List of three arguments.
+
+=item * Return Value
+
+String holding augmented version of second argument.
+
+=back
+
+=cut
+
sub map_type {
- my ($type, $varname, $hiertype) = @_;
+ my ($self, $type, $varname) = @_;
# C++ has :: in types too so skip this
- $type =~ tr/:/_/ unless $hiertype;
+ $type =~ tr/:/_/ unless $self->{hiertype};
$type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
if ($varname) {
if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
return $type;
}
+=head2 C<standard_XS_defs()>
+
+=over 4
+
+=item * Purpose
+
+Writes to the C<.c> output file certain preprocessor directives and function
+headers needed in all such files.
+
+=item * Arguments
+
+None.
+
+=item * Return Value
+
+Implicitly returns true when final C<print> statement completes.
+
+=back
+
+=cut
+
sub standard_XS_defs {
print <<"EOF";
#ifndef PERL_UNUSED_VAR
EOF
}
+=head2 C<assign_func_args()>
+
+=over 4
+
+=item * Purpose
+
+Perform assignment to the C<func_args> attribute.
+
+=item * Arguments
+
+ $string = assign_func_args($self, $argsref, $class);
+
+List of three elements. Second is an array reference; third is a string.
+
+=item * Return Value
+
+String.
+
+=back
+
+=cut
+
sub assign_func_args {
my ($self, $argsref, $class) = @_;
my @func_args = @{$argsref};
shift @func_args if defined($class);
- for (@func_args) {
- s/^/&/ if $self->{in_out}->{$_};
+ for my $arg (@func_args) {
+ $arg =~ s/^/&/ if $self->{in_out}->{$arg};
}
return join(", ", @func_args);
}
-sub print_preprocessor_statements {
- my ($self, $XSS_work_idx, $BootCode_ref) = @_;
+=head2 C<analyze_preprocessor_statements()>
+
+=over 4
+
+=item * Purpose
+
+Within each function inside each Xsub, print to the F<.c> output file certain
+preprocessor statements.
+
+=item * Arguments
+
+ ( $self, $XSS_work_idx, $BootCode_ref ) =
+ analyze_preprocessor_statements(
+ $self, $statement, $XSS_work_idx, $BootCode_ref
+ );
+
+List of four elements.
+
+=item * Return Value
+
+Modifed values of three of the arguments passed to the function. In
+particular, the C<XSStack> and C<InitFileCode> attributes are modified.
+
+=back
+
+=cut
+
+sub analyze_preprocessor_statements {
+ my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
- my $statement = $+;
if ($statement eq 'if') {
$XSS_work_idx = @{ $self->{XSStack} };
push(@{ $self->{XSStack} }, {type => 'if'});
return ($self, $XSS_work_idx, $BootCode_ref);
}
+=head2 C<set_cond()>
+
+=over 4
+
+=item * Purpose
+
+=item * Arguments
+
+=item * Return Value
+
+=back
+
+=cut
+
sub set_cond {
my ($ellipsis, $min_args, $num_args) = @_;
my $cond;
return $cond;
}
+=head2 C<Warn()>
+
+=over 4
+
+=item * Purpose
+
+=item * Arguments
+
+=item * Return Value
+
+=back
+
+=cut
+
sub Warn {
my $self = shift;
# work out the line number
print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
}
+=head2 C<blurt()>
+
+=over 4
+
+=item * Purpose
+
+=item * Arguments
+
+=item * Return Value
+
+=back
+
+=cut
+
sub blurt {
my $self = shift;
Warn($self, @_);
$self->{errors}++
}
+=head2 C<death()>
+
+=over 4
+
+=item * Purpose
+
+=item * Arguments
+
+=item * Return Value
+
+=back
+
+=cut
+
sub death {
my $self = shift;
Warn($self, @_);
exit 1;
}
+=head2 C<check_conditional_preprocessor_statements()>
+
+=over 4
+
+=item * Purpose
+
+=item * Arguments
+
+=item * Return Value
+
+=back
+
+=cut
+
sub check_conditional_preprocessor_statements {
my ($self) = @_;
my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
map_type
);
-my ($type, $varname, $hiertype);
+my ($self, $type, $varname);
my ($result, $expected);
$type = 'struct DATA *';
$varname = 'RETVAL';
-$hiertype = 0;
+$self->{hiertype} = 0;
$expected = "$type\t$varname";
-$result = map_type($type, $varname, $hiertype);
+$result = map_type($self, $type, $varname);
is( $result, $expected,
- "Got expected map_type for <$type>, <$varname>, <$hiertype>" );
+ "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" );
$type = 'Crypt::Shark';
$varname = undef;
-$hiertype = 0;
+$self->{hiertype} = 0;
$expected = 'Crypt__Shark';
-$result = map_type($type, $varname, $hiertype);
+$result = map_type($self, $type, $varname);
is( $result, $expected,
- "Got expected map_type for <$type>, undef, <$hiertype>" );
+ "Got expected map_type for <$type>, undef, <$self->{hiertype}>" );
$type = 'Crypt::Shark';
$varname = undef;
-$hiertype = 1;
+$self->{hiertype} = 1;
$expected = 'Crypt::Shark';
-$result = map_type($type, $varname, $hiertype);
+$result = map_type($self, $type, $varname);
is( $result, $expected,
- "Got expected map_type for <$type>, undef, <$hiertype>" );
+ "Got expected map_type for <$type>, undef, <$self->{hiertype}>" );
$type = 'Crypt::TC18';
$varname = 'RETVAL';
-$hiertype = 0;
+$self->{hiertype} = 0;
$expected = "Crypt__TC18\t$varname";
-$result = map_type($type, $varname, $hiertype);
+$result = map_type($self, $type, $varname);
is( $result, $expected,
- "Got expected map_type for <$type>, <$varname>, <$hiertype>" );
+ "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" );
$type = 'Crypt::TC18';
$varname = 'RETVAL';
-$hiertype = 1;
+$self->{hiertype} = 1;
$expected = "Crypt::TC18\t$varname";
-$result = map_type($type, $varname, $hiertype);
+$result = map_type($self, $type, $varname);
is( $result, $expected,
- "Got expected map_type for <$type>, <$varname>, <$hiertype>" );
+ "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" );
$type = 'array(alpha,beta) gamma';
$varname = 'RETVAL';
-$hiertype = 0;
+$self->{hiertype} = 0;
$expected = "alpha *\t$varname";
-$result = map_type($type, $varname, $hiertype);
+$result = map_type($self, $type, $varname);
is( $result, $expected,
- "Got expected map_type for <$type>, <$varname>, <$hiertype>" );
+ "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" );
$type = '(*)';
$varname = 'RETVAL';
-$hiertype = 0;
+$self->{hiertype} = 0;
$expected = "(* $varname )";
-$result = map_type($type, $varname, $hiertype);
+$result = map_type($self, $type, $varname);
is( $result, $expected,
- "Got expected map_type for <$type>, <$varname>, <$hiertype>" );
+ "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" );
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");
#!/usr/bin/perl
use strict;
use warnings;
-use Carp;
-use Cwd;
-use File::Spec;
-use File::Temp qw( tempdir );
-use Test::More qw(no_plan); # tests => 7;
-use lib qw( lib );
+$| = 1;
+use Test::More tests => 5;
+use lib qw( lib t/lib );
use ExtUtils::ParseXS::Utilities qw(
standard_XS_defs
);
+use PrimitiveCapture;
+
+my @statements = (
+ '#ifndef PERL_UNUSED_VAR',
+ '#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE',
+ '#ifdef PERL_IMPLICIT_CONTEXT',
+ '#ifdef newXS_flags',
+);
+
+my $stdout = PrimitiveCapture::capture_stdout(sub {
+ standard_XS_defs();
+});
+
+foreach my $s (@statements) {
+ like( $stdout, qr/$s/s, "Printed <$s>" );
+}
pass("Passed all tests in $0");
assign_func_args
);
+#sub assign_func_args {
+# my ($self, $argsref, $class) = @_;
+# return join(", ", @func_args);
+
+my ($self, @args, $class);
+my ($func_args, $expected);
+
+@args = qw( alpha beta gamma );
+$self->{in_out}->{alpha} = 'OUT';
+$expected = q|&alpha, beta, gamma|;
+$func_args = assign_func_args($self, \@args, $class);
+is( $func_args, $expected,
+ "Got expected func_args: in_out true; class undefined" );
+
+@args = ( 'My::Class', qw( beta gamma ) );
+$self->{in_out}->{beta} = 'OUT';
+$class = 'My::Class';
+$expected = q|&beta, gamma|;
+$func_args = assign_func_args($self, \@args, $class);
+is( $func_args, $expected,
+ "Got expected func_args: in_out true; class defined" );
+
+@args = ( 'My::Class', qw( beta gamma ) );
+$self->{in_out}->{beta} = '';
+$class = 'My::Class';
+$expected = q|beta, gamma|;
+$func_args = assign_func_args($self, \@args, $class);
+is( $func_args, $expected,
+ "Got expected func_args: in_out false; class defined" );
+
+@args = qw( alpha beta gamma );
+$self->{in_out}->{alpha} = '';
+$class = undef;
+$expected = q|alpha, beta, gamma|;
+$func_args = assign_func_args($self, \@args, $class);
+is( $func_args, $expected,
+ "Got expected func_args: in_out false; class undefined" );
+
pass("Passed all tests in $0");
#!/usr/bin/perl
use strict;
use warnings;
+$| = 1;
use Carp;
use Cwd;
use File::Spec;
use Test::More qw(no_plan); # tests => 7;
use lib qw( lib );
use ExtUtils::ParseXS::Utilities qw(
- print_preprocessor_statements
+ analyze_preprocessor_statements
);
+# ( $self, $XSS_work_idx, $BootCode_ref ) =
+# analyze_preprocessor_statements(
+# $self, $statement, $XSS_work_idx, $BootCode_ref
+# );
+
pass("Passed all tests in $0");
+
+
use Cwd;
use File::Spec;
use File::Temp qw( tempdir );
-use Capture::Tiny qw( capture );
use Test::More tests => 13;
-use lib qw( lib );
+use lib qw( lib t/lib );
use ExtUtils::ParseXS::Utilities qw(
check_conditional_preprocessor_statements
);
+use PrimitiveCapture;
my $self = {};
$self->{line} = [];
$self->{XSStack}->[-1]{type} = 'if';
$self->{filename} = 'myfile1';
- my ($stdout, $stderr, $rv);
- ($stdout, $stderr) = capture {
+ my $rv;
+ my $stderr = PrimitiveCapture::capture_stderr(sub {
$rv = check_conditional_preprocessor_statements($self);
- };
+ });
is( $rv, 0, "Basic case: returned 0: all ifs resolved" );
ok( ! $stderr, "No warnings captured, as expected" );
$self->{XSStack}->[-1]{type} = 'if';
$self->{filename} = 'myfile1';
- my ($stdout, $stderr, $rv);
- ($stdout, $stderr) = capture {
+ my $rv;
+ my $stderr = PrimitiveCapture::capture_stderr(sub {
$rv = check_conditional_preprocessor_statements($self);
- };
+ });
is( $rv, 0, "One nested if case: returned 0: all ifs resolved" );
ok( ! $stderr, "No warnings captured, as expected" );
}
$self->{XSStack}->[-1]{type} = 'if';
$self->{filename} = 'myfile1';
- my ($stdout, $stderr, $rv);
- ($stdout, $stderr) = capture {
+ my $rv;
+ my $stderr = PrimitiveCapture::capture_stderr(sub {
$rv = check_conditional_preprocessor_statements($self);
- };
+ });
is( $rv, undef,
"Missing 'if' case: returned undef: all ifs resolved" );
like( $stderr,
$self->{XSStack}->[-1]{type} = 'file';
$self->{filename} = 'myfile1';
- my ($stdout, $stderr, $rv);
- ($stdout, $stderr) = capture {
+ my $rv;
+ my $stderr = PrimitiveCapture::capture_stderr(sub {
$rv = check_conditional_preprocessor_statements($self);
- };
+ });
is( $rv, undef,
"Missing 'if' case: returned undef: all ifs resolved" );
like( $stderr,
$self->{XSStack}->[-1]{type} = 'if';
$self->{filename} = 'myfile1';
- my ($stdout, $stderr, $rv);
- ($stdout, $stderr) = capture {
+ my $rv;
+ my $stderr = PrimitiveCapture::capture_stderr(sub {
$rv = check_conditional_preprocessor_statements($self);
- };
+ });
isnt( $rv, 0,
"Missing 'endif' case: returned non-zero as expected" );
like( $stderr,
#!/usr/bin/perl
use strict;
use warnings;
+$| = 1;
use Carp;
use Cwd;
use File::Spec;
use File::Temp qw( tempdir );
-use Capture::Tiny qw( capture );
use Test::More tests => 7;
-use lib qw( lib );
+use lib qw( lib t/lib );
use ExtUtils::ParseXS::Utilities qw(
Warn
blurt
death
);
+use PrimitiveCapture;
my $self = {};
$self->{line} = [];
my $message = 'Warning: Ignoring duplicate alias';
- my ($stdout, $stderr) = capture {
+ my $stderr = PrimitiveCapture::capture_stderr(sub {
Warn( $self, $message);
- };
+ });
like( $stderr,
qr/$message in $self->{filename}, line 20/,
"Got expected Warn output",
$self->{filename} = 'myfile2';
my $message = 'Warning: Ignoring duplicate alias';
- my ($stdout, $stderr) = capture {
+ my $stderr = PrimitiveCapture::capture_stderr(sub {
Warn( $self, $message);
- };
+ });
like( $stderr,
qr/$message in $self->{filename}, line 19/,
"Got expected Warn output",
$self->{filename} = 'myfile1';
my $message = 'Warning: Ignoring duplicate alias';
- my ($stdout, $stderr) = capture {
+ my $stderr = PrimitiveCapture::capture_stderr(sub {
Warn( $self, $message);
- };
+ });
like( $stderr,
qr/$message in $self->{filename}, line 17/,
"Got expected Warn output",
my $message = 'Error: Cannot parse function definition';
- my ($stdout, $stderr) = capture {
+ my $stderr = PrimitiveCapture::capture_stderr(sub {
blurt( $self, $message);
- };
+ });
like( $stderr,
qr/$message in $self->{filename}, line 20/,
"Got expected blurt output",
my $message = "Code is not inside a function";
eval {
- my ($stdout, $stderr) = capture {
+ my $stderr = PrimitiveCapture::capture_stderr(sub {
death( $self, $message);
- };
+ });
like( $stderr,
qr/$message in $self->{filename}, line 20/,
"Got expected death output",
--- /dev/null
+package PrimitiveCapture;
+use strict;
+use warnings;
+
+sub capture_stdout {
+ my $sub = shift;
+ my $stdout;
+ open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!";
+ close STDOUT;
+ open STDOUT, '>', \$stdout or die "Can't open STDOUT: $!";
+
+ $sub->();
+
+ close STDOUT;
+ open STDOUT, ">&", $oldout or die "Can't dup \$oldout: $!";
+ return $stdout;
+}
+
+sub capture_stderr {
+ my $sub = shift;
+ my $stderr;
+ open my $olderr, ">&STDERR" or die "Can't dup STDERR: $!";
+ close STDERR;
+ open STDERR, '>', \$stderr or die "Can't open STDERR: $!";
+
+ $sub->();
+
+ close STDERR;
+ open STDERR, ">&", $olderr or die "Can't dup \$olderr: $!";
+ return $stderr;
+}
+
+1;
projects / platform / upstream / perl.git / commitdiff