From 361d4be63e3524dfef7e707b7fa0293ce72c6bf2 Mon Sep 17 00:00:00 2001 From: "James E. Keenan" Date: Sun, 11 Apr 2010 16:48:23 -0400 Subject: [PATCH] Mostly adding tests and documentation. Rename sub print_preprocessor_statements() to analyze_preprocessor_statements(). Modify interface to map_type() and re-work tests as needed. Wrote documentation in Utilities.pm for process_single_typemap(), map_type(), standard_XS_defs(), assign_func_args(), analyze_preprocessor_statements(). Write tests in t/109-standard_XS_defs.t, t/110-assign_func_args.t. --- MANIFEST | 3 +- dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm | 13 +- .../lib/ExtUtils/ParseXS/Utilities.pm | 206 +++++++++++++++++++-- dist/ExtUtils-ParseXS/t/104-map_type.t | 44 ++--- dist/ExtUtils-ParseXS/t/108-map_type.t | 4 + dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t | 25 ++- dist/ExtUtils-ParseXS/t/110-assign_func_args.t | 38 ++++ ...nts.t => 111-analyze_preprocessor_statements.t} | 10 +- .../t/113-check_cond_preproc_statements.t | 34 ++-- dist/ExtUtils-ParseXS/t/114-blurt_death_Warn.t | 25 +-- dist/ExtUtils-ParseXS/t/lib/PrimitiveCapture.pm | 33 ++++ 11 files changed, 359 insertions(+), 76 deletions(-) rename dist/ExtUtils-ParseXS/t/{111-print_preprocessor_statements.t => 111-analyze_preprocessor_statements.t} (53%) create mode 100644 dist/ExtUtils-ParseXS/t/lib/PrimitiveCapture.pm diff --git a/MANIFEST b/MANIFEST index cff5970..a6defc7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2992,11 +2992,12 @@ dist/ExtUtils-ParseXS/t/107-make_targetable.t ExtUtils::ParseXS tests 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 diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm index 37f6552..156f6e5 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm @@ -21,7 +21,7 @@ use ExtUtils::ParseXS::Utilities qw( map_type standard_XS_defs assign_func_args - print_preprocessor_statements + analyze_preprocessor_statements set_cond Warn blurt @@ -273,8 +273,11 @@ EOM 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} }; @@ -621,7 +624,7 @@ EOF } 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}; @@ -1092,11 +1095,11 @@ sub INPUT_handler { 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}; diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm index ef22fdc..b25df02 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm @@ -19,7 +19,7 @@ our (@ISA, @EXPORT_OK); map_type standard_XS_defs assign_func_args - print_preprocessor_statements + analyze_preprocessor_statements set_cond Warn blurt @@ -310,6 +310,31 @@ sub process_typemaps { return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref); } +=head2 C + +=over 4 + +=item * Purpose + +Process a single typemap within C. + +=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) = @_; @@ -347,10 +372,6 @@ sub process_single_typemap { $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/) { @@ -421,11 +442,33 @@ sub make_targetable { return %targetable; } +=head2 C + +=over 4 + +=item * Purpose + +Performs a mapping at several places inside C 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) { @@ -438,6 +481,27 @@ sub map_type { return $type; } +=head2 C + +=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 statement completes. + +=back + +=cut + sub standard_XS_defs { print <<"EOF"; #ifndef PERL_UNUSED_VAR @@ -497,21 +561,69 @@ S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) EOF } +=head2 C + +=over 4 + +=item * Purpose + +Perform assignment to the C 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 + +=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 and C 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'}); @@ -542,6 +654,20 @@ sub print_preprocessor_statements { return ($self, $XSS_work_idx, $BootCode_ref); } +=head2 C + +=over 4 + +=item * Purpose + +=item * Arguments + +=item * Return Value + +=back + +=cut + sub set_cond { my ($ellipsis, $min_args, $num_args) = @_; my $cond; @@ -557,6 +683,20 @@ sub set_cond { return $cond; } +=head2 C + +=over 4 + +=item * Purpose + +=item * Arguments + +=item * Return Value + +=back + +=cut + sub Warn { my $self = shift; # work out the line number @@ -565,18 +705,60 @@ sub Warn { print STDERR "@_ in $self->{filename}, line $warn_line_number\n"; } +=head2 C + +=over 4 + +=item * Purpose + +=item * Arguments + +=item * Return Value + +=back + +=cut + sub blurt { my $self = shift; Warn($self, @_); $self->{errors}++ } +=head2 C + +=over 4 + +=item * Purpose + +=item * Arguments + +=item * Return Value + +=back + +=cut + sub death { my $self = shift; Warn($self, @_); exit 1; } +=head2 C + +=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} }); diff --git a/dist/ExtUtils-ParseXS/t/104-map_type.t b/dist/ExtUtils-ParseXS/t/104-map_type.t index 2c5ae30..01e784e 100644 --- a/dist/ExtUtils-ParseXS/t/104-map_type.t +++ b/dist/ExtUtils-ParseXS/t/104-map_type.t @@ -7,61 +7,61 @@ use ExtUtils::ParseXS::Utilities qw( 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}>" ); diff --git a/dist/ExtUtils-ParseXS/t/108-map_type.t b/dist/ExtUtils-ParseXS/t/108-map_type.t index 7414e54..ba08f6c 100644 --- a/dist/ExtUtils-ParseXS/t/108-map_type.t +++ b/dist/ExtUtils-ParseXS/t/108-map_type.t @@ -11,4 +11,8 @@ 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/109-standard_XS_defs.t b/dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t index e5594ae..0cb7493 100644 --- a/dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t +++ b/dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t @@ -1,14 +1,27 @@ #!/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"); diff --git a/dist/ExtUtils-ParseXS/t/110-assign_func_args.t b/dist/ExtUtils-ParseXS/t/110-assign_func_args.t index 64e9c8f..63d9784 100644 --- a/dist/ExtUtils-ParseXS/t/110-assign_func_args.t +++ b/dist/ExtUtils-ParseXS/t/110-assign_func_args.t @@ -11,4 +11,42 @@ use ExtUtils::ParseXS::Utilities qw( 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"); diff --git a/dist/ExtUtils-ParseXS/t/111-print_preprocessor_statements.t b/dist/ExtUtils-ParseXS/t/111-analyze_preprocessor_statements.t similarity index 53% rename from dist/ExtUtils-ParseXS/t/111-print_preprocessor_statements.t rename to dist/ExtUtils-ParseXS/t/111-analyze_preprocessor_statements.t index fdb1210..b9d6d73 100644 --- a/dist/ExtUtils-ParseXS/t/111-print_preprocessor_statements.t +++ b/dist/ExtUtils-ParseXS/t/111-analyze_preprocessor_statements.t @@ -1,6 +1,7 @@ #!/usr/bin/perl use strict; use warnings; +$| = 1; use Carp; use Cwd; use File::Spec; @@ -8,7 +9,14 @@ use File::Temp qw( tempdir ); 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"); + + diff --git a/dist/ExtUtils-ParseXS/t/113-check_cond_preproc_statements.t b/dist/ExtUtils-ParseXS/t/113-check_cond_preproc_statements.t index a6cbd50..42f3791 100644 --- a/dist/ExtUtils-ParseXS/t/113-check_cond_preproc_statements.t +++ b/dist/ExtUtils-ParseXS/t/113-check_cond_preproc_statements.t @@ -5,12 +5,12 @@ use Carp; 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} = []; @@ -31,10 +31,10 @@ $self->{XSStack}->[0] = {}; $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" ); @@ -54,10 +54,10 @@ $self->{XSStack}->[0] = {}; $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" ); } @@ -75,10 +75,10 @@ $self->{XSStack}->[0] = {}; $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, @@ -104,10 +104,10 @@ $self->{XSStack}->[0] = {}; $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, @@ -133,10 +133,10 @@ $self->{XSStack}->[0] = {}; $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, diff --git a/dist/ExtUtils-ParseXS/t/114-blurt_death_Warn.t b/dist/ExtUtils-ParseXS/t/114-blurt_death_Warn.t index 298bf10..71a637e 100644 --- a/dist/ExtUtils-ParseXS/t/114-blurt_death_Warn.t +++ b/dist/ExtUtils-ParseXS/t/114-blurt_death_Warn.t @@ -1,18 +1,19 @@ #!/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} = []; @@ -30,9 +31,9 @@ $self->{line_no} = []; 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", @@ -51,9 +52,9 @@ $self->{line_no} = []; $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", @@ -71,9 +72,9 @@ $self->{line_no} = []; $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", @@ -93,9 +94,9 @@ $self->{line_no} = []; 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", @@ -117,9 +118,9 @@ SKIP: { 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", diff --git a/dist/ExtUtils-ParseXS/t/lib/PrimitiveCapture.pm b/dist/ExtUtils-ParseXS/t/lib/PrimitiveCapture.pm new file mode 100644 index 0000000..aa873d4 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/lib/PrimitiveCapture.pm @@ -0,0 +1,33 @@ +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; -- 2.7.4