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