This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add test of EU::Typemap output against old ParseXS code
[perl5.git] / dist / ExtUtils-ParseXS / t / 600-t-compat.t
1 #!/usr/bin/perl
2 use strict;
3 use warnings;
4
5 use Test::More tests => 1;
6
7 # This test is for making sure that the new EU::Typemaps
8 # based typemap merging produces the same result as the old
9 # EU::ParseXS code.
10
11 use ExtUtils::Typemaps;
12 use ExtUtils::ParseXS::Utilities qw(
13   C_string
14   tidy_type
15   trim_whitespace
16   process_typemaps
17 );
18 use ExtUtils::ParseXS::Constants;
19 use File::Spec;
20
21 my $path_prefix = File::Spec->catdir(-d 't' ? qw(t data) : qw(data));
22 my @local_tmaps = (
23   File::Spec->catdir($path_prefix, "conflicting.typemap"),
24 );
25
26 SCOPE: {
27   no warnings 'redefine';
28   my @standard_typemap_locations = (
29     File::Spec->catdir($path_prefix, "other.typemap"),
30   );
31   sub ExtUtils::ParseXS::Utilities::standard_typemap_locations {
32     @standard_typemap_locations;
33   }
34   sub standard_typemap_locations {
35     @standard_typemap_locations;
36   }
37 }
38
39 my $res = [_process_typemaps([@local_tmaps], '.')];
40 my $res_new = [process_typemaps([@local_tmaps], '.')];
41
42 # Normalize trailing whitespace. Let's be that lenient, mkay?
43 for ($res, $res_new) {
44   for ($_->[2], $_->[3]) {
45     for (values %$_) {
46       s/\s+\z//;
47     }
48   }
49 }
50 #use Data::Dumper; warn Dumper $res;
51 #use Data::Dumper; warn Dumper $res_new;
52
53 is_deeply($res_new, $res);
54
55 sub _process_typemaps {
56   my ($tmap, $pwd) = @_;
57
58   my @tm = ref $tmap ? @{$tmap} : ($tmap);
59
60   foreach my $typemap (@tm) {
61     die "Can't find $typemap in $pwd\n" unless -r $typemap;
62   }
63
64   push @tm, standard_typemap_locations( \@INC );
65
66   my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref)
67     = ( {}, {}, {}, {} );
68
69   foreach my $typemap (@tm) {
70     next unless -f $typemap;
71     # skip directories, binary files etc.
72     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
73       unless -T $typemap;
74     ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
75       _process_single_typemap( $typemap,
76         $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
77   }
78   return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
79 }
80
81 sub _process_single_typemap {
82   my ($typemap,
83     $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = @_;
84   open my $TYPEMAP, '<', $typemap
85     or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
86   my $mode = 'Typemap';
87   my $junk = "";
88   my $current = \$junk;
89   while (<$TYPEMAP>) {
90     # skip comments
91     next if /^\s*#/;
92     if (/^INPUT\s*$/) {
93       $mode = 'Input';   $current = \$junk;  next;
94     }
95     if (/^OUTPUT\s*$/) {
96       $mode = 'Output';  $current = \$junk;  next;
97     }
98     if (/^TYPEMAP\s*$/) {
99       $mode = 'Typemap'; $current = \$junk;  next;
100     }
101     if ($mode eq 'Typemap') {
102       chomp;
103       my $logged_line = $_;
104       trim_whitespace($_);
105       # skip blank lines
106       next if /^$/;
107       my($type,$kind, $proto) =
108         m/^\s*(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)\s*$/
109           or warn(
110             "Warning: File '$typemap' Line $.  '$logged_line' " .
111             "TYPEMAP entry needs 2 or 3 columns\n"
112           ),
113           next;
114       $type = tidy_type($type);
115       $type_kind_ref->{$type} = $kind;
116       # prototype defaults to '$'
117       $proto = "\$" unless $proto;
118       $proto_letter_ref->{$type} = C_string($proto);
119     }
120     elsif (/^\s/) {
121       $$current .= $_;
122     }
123     elsif ($mode eq 'Input') {
124       s/\s+$//;
125       $input_expr_ref->{$_} = '';
126       $current = \$input_expr_ref->{$_};
127     }
128     else {
129       s/\s+$//;
130       $output_expr_ref->{$_} = '';
131       $current = \$output_expr_ref->{$_};
132     }
133   }
134   close $TYPEMAP;
135   return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
136 }