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