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