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