This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Explicitly pass $hiertype to map_type()
[perl5.git] / dist / ExtUtils-ParseXS / lib / ExtUtils / ParseXS / Utilities.pm
CommitLineData
a65c06db
S
1package ExtUtils::ParseXS::Utilities;
2use strict;
3use warnings;
4use Exporter;
f3aadd09 5use File::Spec;
547742ac
JK
6use lib qw( lib );
7use ExtUtils::ParseXS::Constants ();
a65c06db
S
8our (@ISA, @EXPORT_OK);
9@ISA = qw(Exporter);
10@EXPORT_OK = qw(
11 standard_typemap_locations
1d40e528 12 trim_whitespace
73e91d5a 13 tidy_type
c1e43162 14 C_string
547742ac 15 valid_proto_string
50b96cc2 16 process_typemaps
af4112ab 17 make_targetable
0ec7450c 18 map_type
a65c06db
S
19);
20
f3aadd09
S
21=head1 NAME
22
23ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS
24
25=head1 SYNOPSIS
26
27 use ExtUtils::ParseXS::Utilities qw(
28 standard_typemap_locations
1d40e528 29 trim_whitespace
73e91d5a 30 tidy_type
3f0c8333
JK
31 C_string
32 valid_proto_string
33 process_typemaps
34 make_targetable
f3aadd09
S
35 );
36
37=head1 SUBROUTINES
38
39The following functions are not considered to be part of the public interface.
40They are documented here for the benefit of future maintainers of this module.
41
42=head2 C<standard_typemap_locations()>
43
44=over 4
45
46=item * Purpose
47
48Provide a list of filepaths where F<typemap> files may be found. The
49filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority.
50
51The highest priority is to look in the current directory.
52
53 'typemap'
54
55The second and third highest priorities are to look in the parent of the
56current directory and a directory called F<lib/ExtUtils> underneath the parent
57directory.
58
59 '../typemap',
60 '../lib/ExtUtils/typemap',
61
62The fourth through ninth highest priorities are to look in the corresponding
63grandparent, great-grandparent and great-great-grandparent directories.
64
65 '../../typemap',
66 '../../lib/ExtUtils/typemap',
67 '../../../typemap',
68 '../../../lib/ExtUtils/typemap',
69 '../../../../typemap',
70 '../../../../lib/ExtUtils/typemap',
71
72The tenth and subsequent priorities are to look in directories named
73F<ExtUtils> which are subdirectories of directories found in C<@INC> --
74I<provided> a file named F<typemap> actually exists in such a directory.
75Example:
76
77 '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
78
79However, these filepaths appear in the list returned by
80C<standard_typemap_locations()> in reverse order, I<i.e.>, lowest-to-highest.
81
82 '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
83 '../../../../lib/ExtUtils/typemap',
84 '../../../../typemap',
85 '../../../lib/ExtUtils/typemap',
86 '../../../typemap',
87 '../../lib/ExtUtils/typemap',
88 '../../typemap',
89 '../lib/ExtUtils/typemap',
90 '../typemap',
91 'typemap'
92
93=item * Arguments
94
95 my @stl = standard_typemap_locations( \@INC );
96
97Reference to C<@INC>.
98
99=item * Return Value
100
101Array holding list of directories to be searched for F<typemap> files.
102
103=back
104
105=cut
106
a65c06db
S
107sub standard_typemap_locations {
108 my $include_ref = shift;
a65c06db
S
109 my @tm = qw(typemap);
110
f3aadd09
S
111 my $updir = File::Spec->updir();
112 foreach my $dir (
113 File::Spec->catdir(($updir) x 1),
114 File::Spec->catdir(($updir) x 2),
115 File::Spec->catdir(($updir) x 3),
116 File::Spec->catdir(($updir) x 4),
117 ) {
a65c06db
S
118 unshift @tm, File::Spec->catfile($dir, 'typemap');
119 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
120 }
121 foreach my $dir (@{ $include_ref}) {
122 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
123 unshift @tm, $file if -e $file;
124 }
125 return @tm;
126}
127
1d40e528
JK
128=head2 C<trim_whitespace()>
129
130=over 4
131
132=item * Purpose
133
134Perform an in-place trimming of leading and trailing whitespace from the
135first argument provided to the function.
136
137=item * Argument
138
139 trim_whitespace($arg);
140
141=item * Return Value
142
143None. Remember: this is an I<in-place> modification of the argument.
144
145=back
146
147=cut
148
149sub trim_whitespace {
150 $_[0] =~ s/^\s+|\s+$//go;
151}
152
73e91d5a
JK
153=head2 C<tidy_type()>
154
155=over 4
156
157=item * Purpose
158
159Rationalize any asterisks (C<*>) by joining them into bunches, removing
160interior whitespace, then trimming leading and trailing whitespace.
161
162=item * Arguments
163
164 ($ret_type) = tidy_type($_);
165
166String to be cleaned up.
167
168=item * Return Value
169
170String cleaned up.
171
172=back
173
174=cut
175
176sub tidy_type {
177 local ($_) = @_;
178
179 # rationalise any '*' by joining them into bunches and removing whitespace
180 s#\s*(\*+)\s*#$1#g;
181 s#(\*+)# $1 #g;
182
183 # change multiple whitespace into a single space
184 s/\s+/ /g;
185
186 # trim leading & trailing whitespace
187 trim_whitespace($_);
188
189 $_;
190}
191
c1e43162
JK
192=head2 C<C_string()>
193
194=over 4
195
196=item * Purpose
197
198Escape backslashes (C<\>) in prototype strings.
199
200=item * Arguments
201
202 $ProtoThisXSUB = C_string($_);
203
204String needing escaping.
205
206=item * Return Value
207
208Properly escaped string.
209
210=back
211
212=cut
213
214sub C_string {
215 my($string) = @_;
216
217 $string =~ s[\\][\\\\]g;
218 $string;
219}
220
547742ac
JK
221=head2 C<valid_proto_string()>
222
223=over 4
224
225=item * Purpose
226
227Validate prototype string.
228
229=item * Arguments
230
231String needing checking.
232
233=item * Return Value
234
235Upon success, returns the same string passed as argument.
236
237Upon failure, returns C<0>.
238
239=back
240
241=cut
242
243sub valid_proto_string {
244 my($string) = @_;
245
246 if ( $string =~ /^$ExtUtils::ParseXS::Constants::proto_re+$/ ) {
247 return $string;
248 }
249
250 return 0;
251}
50b96cc2
JK
252
253=head2 C<process_typemaps()>
254
255=over 4
256
257=item * Purpose
258
259Process all typemap files.
260
261=item * Arguments
262
263 my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
264 process_typemaps( $args{typemap}, $pwd );
265
266List of two elements: C<typemap> element from C<%args>; current working
267directory.
268
269=item * Return Value
270
271Upon success, returns a list of four hash references. (This will probably be
272refactored.)
273
274=back
275
276=cut
277
278sub process_typemaps {
279 my ($tmap, $pwd) = @_;
280
281 my @tm = ref $tmap ? @{$tmap} : ($tmap);
282
283 foreach my $typemap (@tm) {
284 die "Can't find $typemap in $pwd\n" unless -r $typemap;
285 }
286
287 push @tm, standard_typemap_locations( \@INC );
288
289 my (%type_kind, %proto_letter, %input_expr, %output_expr);
290
291 foreach my $typemap (@tm) {
292 next unless -f $typemap;
293 # skip directories, binary files etc.
294 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
295 unless -T $typemap;
296 open my $TYPEMAP, '<', $typemap
297 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
298 my $mode = 'Typemap';
299 my $junk = "";
300 my $current = \$junk;
301 while (<$TYPEMAP>) {
302 next if /^\s*#/;
303 if (/^INPUT\s*$/) {
304 $mode = 'Input'; $current = \$junk; next;
305 }
306 if (/^OUTPUT\s*$/) {
307 $mode = 'Output'; $current = \$junk; next;
308 }
309 if (/^TYPEMAP\s*$/) {
310 $mode = 'Typemap'; $current = \$junk; next;
311 }
312 if ($mode eq 'Typemap') {
313 chomp;
314 my $line = $_;
315 trim_whitespace($_);
316 # skip blank lines and comment lines
317 next if /^$/ or /^#/;
318 my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::proto_re*)\s*$/ or
319 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
320 $type = tidy_type($type);
321 $type_kind{$type} = $kind;
322 # prototype defaults to '$'
323 $proto = "\$" unless $proto;
324 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
325 unless valid_proto_string($proto);
326 $proto_letter{$type} = C_string($proto);
327 }
328 elsif (/^\s/) {
329 $$current .= $_;
330 }
331 elsif ($mode eq 'Input') {
332 s/\s+$//;
333 $input_expr{$_} = '';
334 $current = \$input_expr{$_};
335 }
336 else {
337 s/\s+$//;
338 $output_expr{$_} = '';
339 $current = \$output_expr{$_};
340 }
341 }
342 close $TYPEMAP;
343 }
344 return (\%type_kind, \%proto_letter, \%input_expr, \%output_expr);
345}
346
af4112ab
JK
347=head2 C<make_targetable()>
348
349=over 4
350
351=item * Purpose
352
353Populate C<%targetable>.
354
355=item * Arguments
356
357 %targetable = make_targetable(\%output_expr);
358
359Reference to C<%output_expr>.
360
361=item * Return Value
362
363Hash.
364
365=back
366
367=cut
368
369sub make_targetable {
370 my $output_expr_ref = shift;
371 my ($cast, $size);
372 our $bal;
373 $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
374 $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
375 $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
376
377 my %targetable;
378 foreach my $key (keys %{ $output_expr_ref }) {
379 # We can still bootstrap compile 're', because in code re.pm is
380 # available to miniperl, and does not attempt to load the XS code.
381 use re 'eval';
382
383 my ($t, $with_size, $arg, $sarg) =
384 ($output_expr_ref->{$key} =~
385 m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
386 \s* \( \s* $cast \$arg \s* ,
387 \s* ( (??{ $bal }) ) # Set from
388 ( (??{ $size }) )? # Possible sizeof set-from
389 \) \s* ; \s* $
390 ]x
391 );
392 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
393 }
394 return %targetable;
395}
396
0ec7450c
JK
397sub map_type {
398 my ($type, $varname, $hiertype) = @_;
399
400 # C++ has :: in types too so skip this
401 $type =~ tr/:/_/ unless $hiertype;
402 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
403 if ($varname) {
404 if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
405 (substr $type, pos $type, 0) = " $varname ";
406 }
407 else {
408 $type .= "\t$varname";
409 }
410 }
411 return $type;
412}
413
a65c06db 4141;