This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add comment explaining where terrible code comes from
[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;
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
23 my @tests = (
24   {
25     name => 'Simple conflict',
26     local_maps => [
27       File::Spec->catdir($path_prefix, "conflicting.typemap"),
28     ],
29     std_maps => [
30       File::Spec->catdir($path_prefix, "other.typemap"),
31     ],
32   },
33   {
34     name => 'B',
35     local_maps => [
36       File::Spec->catdir($path_prefix, "b.typemap"),
37     ],
38     std_maps => [],
39   },
40   {
41     name => 'B and perl',
42     local_maps => [
43       File::Spec->catdir($path_prefix, "b.typemap"),
44     ],
45     std_maps => [
46       File::Spec->catdir($path_prefix, "perl.typemap"),
47     ],
48   },
49   {
50     name => 'B and perl and B again',
51     local_maps => [
52       File::Spec->catdir($path_prefix, "b.typemap"),
53     ],
54     std_maps => [
55       File::Spec->catdir($path_prefix, "perl.typemap"),
56       File::Spec->catdir($path_prefix, "b.typemap"),
57     ],
58   },
59 );
60 plan tests => scalar(@tests);
61
62 my @local_tmaps;
63 my @standard_typemap_locations;
64 SCOPE: {
65   no warnings 'redefine';
66   sub ExtUtils::ParseXS::Utilities::standard_typemap_locations {
67     @standard_typemap_locations;
68   }
69   sub standard_typemap_locations {
70     @standard_typemap_locations;
71   }
72 }
73
74 foreach my $test (@tests) {
75   @local_tmaps = @{ $test->{local_maps} };
76   @standard_typemap_locations = @{ $test->{std_maps} };
77
78   my $res = [_process_typemaps([@local_tmaps], '.')];
79   my $res_new = [process_typemaps([@local_tmaps], '.')];
80
81   # Normalize trailing whitespace. Let's be that lenient, mkay?
82   for ($res, $res_new) {
83     for ($_->[2], $_->[3]) {
84       for (values %$_) {
85         s/\s+\z//;
86       }
87     }
88   }
89   #use Data::Dumper; warn Dumper $res;
90   #use Data::Dumper; warn Dumper $res_new;
91
92   is_deeply($res_new, $res, "typemap equivalency for '$test->{name}'");
93 }
94
95
96 # The code below is a reproduction of what the pre-ExtUtils::Typemap
97 # typemap-parsing/handling code in ExtUtils::ParseXS looked like. For
98 # bug-compatibility, we want to produce the same data structures as that
99 # code as much as possible.
100 sub _process_typemaps {
101   my ($tmap, $pwd) = @_;
102
103   my @tm = ref $tmap ? @{$tmap} : ($tmap);
104
105   foreach my $typemap (@tm) {
106     die "Can't find $typemap in $pwd\n" unless -r $typemap;
107   }
108
109   push @tm, standard_typemap_locations( \@INC );
110
111   my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref)
112     = ( {}, {}, {}, {} );
113
114   foreach my $typemap (@tm) {
115     next unless -f $typemap;
116     # skip directories, binary files etc.
117     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
118       unless -T $typemap;
119     ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
120       _process_single_typemap( $typemap,
121         $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
122   }
123   return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
124 }
125
126 sub _process_single_typemap {
127   my ($typemap,
128     $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = @_;
129   open my $TYPEMAP, '<', $typemap
130     or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
131   my $mode = 'Typemap';
132   my $junk = "";
133   my $current = \$junk;
134   while (<$TYPEMAP>) {
135     # skip comments
136     next if /^\s*#/;
137     if (/^INPUT\s*$/) {
138       $mode = 'Input';   $current = \$junk;  next;
139     }
140     if (/^OUTPUT\s*$/) {
141       $mode = 'Output';  $current = \$junk;  next;
142     }
143     if (/^TYPEMAP\s*$/) {
144       $mode = 'Typemap'; $current = \$junk;  next;
145     }
146     if ($mode eq 'Typemap') {
147       chomp;
148       my $logged_line = $_;
149       trim_whitespace($_);
150       # skip blank lines
151       next if /^$/;
152       my($type,$kind, $proto) =
153         m/^\s*(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)\s*$/
154           or warn(
155             "Warning: File '$typemap' Line $.  '$logged_line' " .
156             "TYPEMAP entry needs 2 or 3 columns\n"
157           ),
158           next;
159       $type = tidy_type($type);
160       $type_kind_ref->{$type} = $kind;
161       # prototype defaults to '$'
162       $proto = "\$" unless $proto;
163       $proto_letter_ref->{$type} = C_string($proto);
164     }
165     elsif (/^\s/) {
166       $$current .= $_;
167     }
168     elsif ($mode eq 'Input') {
169       s/\s+$//;
170       $input_expr_ref->{$_} = '';
171       $current = \$input_expr_ref->{$_};
172     }
173     else {
174       s/\s+$//;
175       $output_expr_ref->{$_} = '';
176       $current = \$output_expr_ref->{$_};
177     }
178   }
179   close $TYPEMAP;
180   return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
181 }