This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add documentation and additional tests
[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
361d4be6 22 analyze_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
361d4be6
JK
313=head2 C<process_single_typemap()>
314
315=over 4
316
317=item * Purpose
318
319Process a single typemap within C<process_typemaps()>.
320
321=item * Arguments
322
323 ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
324 process_single_typemap( $typemap,
325 $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
326
327List of five elements: The individual typemap needing processing and four
328references.
329
330=item * Return Value
331
332List of four references -- modified versions of those passed in as arguments.
333
334=back
335
336=cut
337
bb5e8eb4
JK
338sub process_single_typemap {
339 my ($typemap,
340 $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = @_;
341 open my $TYPEMAP, '<', $typemap
342 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
343 my $mode = 'Typemap';
344 my $junk = "";
345 my $current = \$junk;
346 while (<$TYPEMAP>) {
347 # skip comments
348 next if /^\s*#/;
349 if (/^INPUT\s*$/) {
350 $mode = 'Input'; $current = \$junk; next;
351 }
352 if (/^OUTPUT\s*$/) {
353 $mode = 'Output'; $current = \$junk; next;
354 }
355 if (/^TYPEMAP\s*$/) {
356 $mode = 'Typemap'; $current = \$junk; next;
357 }
358 if ($mode eq 'Typemap') {
359 chomp;
360 my $logged_line = $_;
361 trim_whitespace($_);
362 # skip blank lines
363 next if /^$/;
364 my($type,$kind, $proto) =
365 m/^\s*(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::proto_re*)\s*$/
366 or warn(
367 "Warning: File '$typemap' Line $. '$logged_line' " .
368 "TYPEMAP entry needs 2 or 3 columns\n"
369 ),
370 next;
371 $type = tidy_type($type);
372 $type_kind_ref->{$type} = $kind;
373 # prototype defaults to '$'
374 $proto = "\$" unless $proto;
bb5e8eb4
JK
375 $proto_letter_ref->{$type} = C_string($proto);
376 }
377 elsif (/^\s/) {
378 $$current .= $_;
379 }
380 elsif ($mode eq 'Input') {
381 s/\s+$//;
382 $input_expr_ref->{$_} = '';
383 $current = \$input_expr_ref->{$_};
384 }
385 else {
386 s/\s+$//;
387 $output_expr_ref->{$_} = '';
388 $current = \$output_expr_ref->{$_};
50b96cc2 389 }
50b96cc2 390 }
bb5e8eb4
JK
391 close $TYPEMAP;
392 return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
50b96cc2
JK
393}
394
af4112ab
JK
395=head2 C<make_targetable()>
396
397=over 4
398
399=item * Purpose
400
401Populate C<%targetable>.
402
403=item * Arguments
404
405 %targetable = make_targetable(\%output_expr);
406
407Reference to C<%output_expr>.
408
409=item * Return Value
410
411Hash.
412
413=back
414
415=cut
416
417sub make_targetable {
418 my $output_expr_ref = shift;
419 my ($cast, $size);
420 our $bal;
421 $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
422 $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
423 $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
424
425 my %targetable;
426 foreach my $key (keys %{ $output_expr_ref }) {
427 # We can still bootstrap compile 're', because in code re.pm is
428 # available to miniperl, and does not attempt to load the XS code.
429 use re 'eval';
430
431 my ($t, $with_size, $arg, $sarg) =
432 ($output_expr_ref->{$key} =~
433 m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
434 \s* \( \s* $cast \$arg \s* ,
435 \s* ( (??{ $bal }) ) # Set from
436 ( (??{ $size }) )? # Possible sizeof set-from
437 \) \s* ; \s* $
438 ]x
439 );
440 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
441 }
442 return %targetable;
443}
444
361d4be6
JK
445=head2 C<map_type()>
446
447=over 4
448
449=item * Purpose
450
451Performs a mapping at several places inside C<PARAGRAPH> loop.
452
453=item * Arguments
454
455 $type = map_type($self, $type, $varname);
456
457List of three arguments.
458
459=item * Return Value
460
461String holding augmented version of second argument.
462
463=back
464
465=cut
466
0ec7450c 467sub map_type {
361d4be6 468 my ($self, $type, $varname) = @_;
0ec7450c
JK
469
470 # C++ has :: in types too so skip this
361d4be6 471 $type =~ tr/:/_/ unless $self->{hiertype};
0ec7450c
JK
472 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
473 if ($varname) {
474 if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
475 (substr $type, pos $type, 0) = " $varname ";
476 }
477 else {
478 $type .= "\t$varname";
479 }
480 }
481 return $type;
482}
483
361d4be6
JK
484=head2 C<standard_XS_defs()>
485
486=over 4
487
488=item * Purpose
489
490Writes to the C<.c> output file certain preprocessor directives and function
491headers needed in all such files.
492
493=item * Arguments
494
495None.
496
497=item * Return Value
498
499Implicitly returns true when final C<print> statement completes.
500
501=back
502
503=cut
504
6c2c48aa
JK
505sub standard_XS_defs {
506 print <<"EOF";
507#ifndef PERL_UNUSED_VAR
508# define PERL_UNUSED_VAR(var) if (0) var = var
509#endif
510
511EOF
512
513 print <<"EOF";
514#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
515#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
516
517/* prototype to pass -Wmissing-prototypes */
518STATIC void
519S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
520
521STATIC void
522S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
523{
524 const GV *const gv = CvGV(cv);
525
526 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
527
528 if (gv) {
529 const char *const gvname = GvNAME(gv);
530 const HV *const stash = GvSTASH(gv);
531 const char *const hvname = stash ? HvNAME(stash) : NULL;
532
533 if (hvname)
534 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
535 else
536 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
537 } else {
538 /* Pants. I don't think that it should be possible to get here. */
539 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
540 }
541}
542#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
543
544#ifdef PERL_IMPLICIT_CONTEXT
545#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
546#else
547#define croak_xs_usage S_croak_xs_usage
548#endif
549
550#endif
551
552/* NOTE: the prototype of newXSproto() is different in versions of perls,
553 * so we define a portable version of newXSproto()
554 */
555#ifdef newXS_flags
556#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
557#else
558#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
559#endif /* !defined(newXS_flags) */
560
561EOF
562}
563
361d4be6
JK
564=head2 C<assign_func_args()>
565
566=over 4
567
568=item * Purpose
569
570Perform assignment to the C<func_args> attribute.
571
572=item * Arguments
573
574 $string = assign_func_args($self, $argsref, $class);
575
576List of three elements. Second is an array reference; third is a string.
577
578=item * Return Value
579
580String.
581
582=back
583
584=cut
585
362926c8
JK
586sub assign_func_args {
587 my ($self, $argsref, $class) = @_;
588 my @func_args = @{$argsref};
589 shift @func_args if defined($class);
590
361d4be6
JK
591 for my $arg (@func_args) {
592 $arg =~ s/^/&/ if $self->{in_out}->{$arg};
362926c8
JK
593 }
594 return join(", ", @func_args);
595}
596
361d4be6
JK
597=head2 C<analyze_preprocessor_statements()>
598
599=over 4
600
601=item * Purpose
602
603Within each function inside each Xsub, print to the F<.c> output file certain
604preprocessor statements.
605
606=item * Arguments
607
608 ( $self, $XSS_work_idx, $BootCode_ref ) =
609 analyze_preprocessor_statements(
610 $self, $statement, $XSS_work_idx, $BootCode_ref
611 );
612
613List of four elements.
614
615=item * Return Value
616
617Modifed values of three of the arguments passed to the function. In
618particular, the C<XSStack> and C<InitFileCode> attributes are modified.
619
620=back
621
622=cut
623
624sub analyze_preprocessor_statements {
625 my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
1d3d7190 626
1d3d7190
JK
627 if ($statement eq 'if') {
628 $XSS_work_idx = @{ $self->{XSStack} };
629 push(@{ $self->{XSStack} }, {type => 'if'});
630 }
631 else {
632 death ("Error: `$statement' with no matching `if'")
633 if $self->{XSStack}->[-1]{type} ne 'if';
634 if ($self->{XSStack}->[-1]{varname}) {
635 push(@{ $self->{InitFileCode} }, "#endif\n");
636 push(@{ $BootCode_ref }, "#endif");
637 }
638
639 my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
640 if ($statement ne 'endif') {
641 # Hide the functions defined in other #if branches, and reset.
642 @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
643 @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
644 }
645 else {
646 my($tmp) = pop(@{ $self->{XSStack} });
647 0 while (--$XSS_work_idx
648 && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
649 # Keep all new defined functions
650 push(@fns, keys %{$tmp->{other_functions}});
651 @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
652 }
653 }
654 return ($self, $XSS_work_idx, $BootCode_ref);
655}
656
361d4be6
JK
657=head2 C<set_cond()>
658
659=over 4
660
661=item * Purpose
662
663=item * Arguments
664
665=item * Return Value
666
667=back
668
669=cut
670
40a3ae2f
JK
671sub set_cond {
672 my ($ellipsis, $min_args, $num_args) = @_;
673 my $cond;
674 if ($ellipsis) {
675 $cond = ($min_args ? qq(items < $min_args) : 0);
676 }
677 elsif ($min_args == $num_args) {
678 $cond = qq(items != $min_args);
679 }
680 else {
681 $cond = qq(items < $min_args || items > $num_args);
682 }
683 return $cond;
684}
685
361d4be6
JK
686=head2 C<Warn()>
687
688=over 4
689
690=item * Purpose
691
692=item * Arguments
693
694=item * Return Value
695
696=back
697
698=cut
699
2a09a23f
JK
700sub Warn {
701 my $self = shift;
702 # work out the line number
703 my $warn_line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
704
705 print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
706}
707
361d4be6
JK
708=head2 C<blurt()>
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 blurt {
723 my $self = shift;
724 Warn($self, @_);
725 $self->{errors}++
726}
727
361d4be6
JK
728=head2 C<death()>
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 death {
743 my $self = shift;
744 Warn($self, @_);
745 exit 1;
746}
747
361d4be6
JK
748=head2 C<check_conditional_preprocessor_statements()>
749
750=over 4
751
752=item * Purpose
753
754=item * Arguments
755
756=item * Return Value
757
758=back
759
760=cut
761
2a09a23f
JK
762sub check_conditional_preprocessor_statements {
763 my ($self) = @_;
764 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
765 if (@cpp) {
766 my $cpplevel;
767 for my $cpp (@cpp) {
768 if ($cpp =~ /^\#\s*if/) {
769 $cpplevel++;
770 }
771 elsif (!$cpplevel) {
772 Warn( $self, "Warning: #else/elif/endif without #if in this function");
773 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
774 if $self->{XSStack}->[-1]{type} eq 'if';
775 return;
776 }
777 elsif ($cpp =~ /^\#\s*endif/) {
778 $cpplevel--;
779 }
780 }
781 Warn( $self, "Warning: #if without #endif in this function") if $cpplevel;
782 }
783}
e6de4093 784
a65c06db 7851;
27b7514f
JK
786
787# vim: ts=2 sw=2 et: