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