1#!/usr/bin/perl
2use strict;
3use warnings;
4
5use 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
11use ExtUtils::Typemaps;
12use ExtUtils::ParseXS::Utilities qw(
13  C_string
14  trim_whitespace
15  process_typemaps
16);
17use ExtUtils::ParseXS::Constants;
18use File::Spec;
19
20my $path_prefix = File::Spec->catdir(-d 't' ? qw(t data) : qw(data));
21
22my @tests = (
23  {
24    name => 'Simple conflict',
25    local_maps => [
26      File::Spec->catfile($path_prefix, "conflicting.typemap"),
27    ],
28    std_maps => [
29      File::Spec->catfile($path_prefix, "other.typemap"),
30    ],
31  },
32  {
33    name => 'B',
34    local_maps => [
35      File::Spec->catfile($path_prefix, "b.typemap"),
36    ],
37    std_maps => [],
38  },
39  {
40    name => 'B and perl',
41    local_maps => [
42      File::Spec->catfile($path_prefix, "b.typemap"),
43    ],
44    std_maps => [
45      File::Spec->catfile($path_prefix, "perl.typemap"),
46    ],
47  },
48  {
49    name => 'B and perl and B again',
50    local_maps => [
51      File::Spec->catfile($path_prefix, "b.typemap"),
52    ],
53    std_maps => [
54      File::Spec->catfile($path_prefix, "perl.typemap"),
55      File::Spec->catfile($path_prefix, "b.typemap"),
56    ],
57  },
58);
59plan tests => scalar(@tests);
60
61my @local_tmaps;
62my @standard_typemap_locations;
63SCOPE: {
64  no warnings 'redefine';
65  sub ExtUtils::ParseXS::Utilities::standard_typemap_locations {
66    @standard_typemap_locations;
67  }
68  sub standard_typemap_locations {
69    @standard_typemap_locations;
70  }
71}
72
73foreach my $test (@tests) {
74  @local_tmaps = @{ $test->{local_maps} };
75  @standard_typemap_locations = @{ $test->{std_maps} };
76
77  my $res = [_process_typemaps([@local_tmaps], '.')];
78  my $tm = process_typemaps([@local_tmaps], '.');
79  my $res_new = [map $tm->$_(), qw(_get_typemap_hash _get_prototype_hash _get_inputmap_hash _get_outputmap_hash) ];
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::Typemaps
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.
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 = ExtUtils::Typemaps::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}
182