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
CommitLineData
e897cbec
S
1#!/usr/bin/perl
2use strict;
3use warnings;
4
2d9f8a35 5use Test::More;
e897cbec
S
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
11use ExtUtils::Typemaps;
12use ExtUtils::ParseXS::Utilities qw(
13 C_string
14 tidy_type
15 trim_whitespace
16 process_typemaps
17);
18use ExtUtils::ParseXS::Constants;
19use File::Spec;
20
21my $path_prefix = File::Spec->catdir(-d 't' ? qw(t data) : qw(data));
2d9f8a35
S
22
23my @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 },
e897cbec 59);
2d9f8a35 60plan tests => scalar(@tests);
e897cbec 61
2d9f8a35
S
62my @local_tmaps;
63my @standard_typemap_locations;
e897cbec
S
64SCOPE: {
65 no warnings 'redefine';
e897cbec
S
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
2d9f8a35
S
74foreach 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], '.')];
e897cbec 80
2d9f8a35
S
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 }
e897cbec
S
87 }
88 }
2d9f8a35
S
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}'");
e897cbec 93}
e897cbec 94
2d9f8a35 95
4ec289a5
S
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.
e897cbec
S
100sub _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
126sub _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}