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