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