This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix function name in documentation
[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
361d4be6 22 analyze_preprocessor_statements
40a3ae2f 23 set_cond
2a09a23f
JK
24 Warn
25 blurt
26 death
27 check_conditional_preprocessor_statements
a65c06db
SM
28);
29
f3aadd09
SM
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
e70aab19 43 process_single_typemap
3f0c8333 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
SM
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
SM
126sub standard_typemap_locations {
127 my $include_ref = shift;
a65c06db
SM
128 my @tm = qw(typemap);
129
f3aadd09
SM
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
SM
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
282 my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
283 process_typemaps( $args{typemap}, $pwd );
284
285List of two elements: C<typemap> element from C<%args>; current working
286directory.
287
288=item * Return Value
289
290Upon success, returns a list of four hash references. (This will probably be
e70aab19
JK
291refactored.) Here is a I<rough> description of what is in these hashrefs:
292
293=over 4
294
295=item * C<$type_kind_ref>
296
297 {
298 'char **' => 'T_PACKEDARRAY',
299 'bool_t' => 'T_IV',
300 'AV *' => 'T_AVREF',
301 'InputStream' => 'T_IN',
302 'double' => 'T_DOUBLE',
303 # ...
304 }
305
6a76c81b 306Keys: C types. Values: XS types identifiers
e70aab19
JK
307
308=item * C<$proto_letter_ref>
309
310 {
311 'char **' => '$',
312 'bool_t' => '$',
313 'AV *' => '$',
314 'InputStream' => '$',
315 'double' => '$',
316 # ...
317 }
318
319Keys: C types. Values. Corresponding prototype letters.
320
321=item * C<$input_expr_ref>
322
323 {
324 'T_CALLBACK' => ' $var = make_perl_cb_$type($arg)
325 ',
326 'T_OUT' => ' $var = IoOFP(sv_2io($arg))
327 ',
328 'T_REF_IV_PTR' => ' if (sv_isa($arg, \\"${ntype}\\")) {
329 # ...
330 }
331
6a76c81b 332Keys: XS typemap identifiers. Values: Newline-terminated strings that
e70aab19
JK
333will be written to C source code (F<.c>) files. The strings are C code, but
334with Perl variables whose values will be interpolated at F<xsubpp>'s runtime
335by one of the C<eval EXPR> statements in ExtUtils::ParseXS.
336
337=item * C<$output_expr_ref>
338
339 {
340 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(),
341 $var.context.value().size());
342 ',
343 'T_OUT' => ' {
344 GV *gv = newGVgen("$Package");
345 if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
346 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
347 else
348 $arg = &PL_sv_undef;
349 }
350 ',
351 # ...
352 }
353
6a76c81b 354Keys: XS typemap identifiers. Values: Newline-terminated strings that
e70aab19
JK
355will be written to C source code (F<.c>) files. The strings are C code, but
356with Perl variables whose values will be interpolated at F<xsubpp>'s runtime
357by one of the C<eval EXPR> statements in ExtUtils::ParseXS.
358
359=back
50b96cc2
JK
360
361=back
362
363=cut
364
365sub process_typemaps {
366 my ($tmap, $pwd) = @_;
367
368 my @tm = ref $tmap ? @{$tmap} : ($tmap);
369
370 foreach my $typemap (@tm) {
371 die "Can't find $typemap in $pwd\n" unless -r $typemap;
372 }
373
374 push @tm, standard_typemap_locations( \@INC );
375
bb5e8eb4
JK
376 my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref)
377 = ( {}, {}, {}, {} );
50b96cc2
JK
378
379 foreach my $typemap (@tm) {
380 next unless -f $typemap;
381 # skip directories, binary files etc.
382 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
383 unless -T $typemap;
bb5e8eb4
JK
384 ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
385 process_single_typemap( $typemap,
386 $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
387 }
388 return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
389}
390
361d4be6
JK
391=head2 C<process_single_typemap()>
392
393=over 4
394
395=item * Purpose
396
397Process a single typemap within C<process_typemaps()>.
398
399=item * Arguments
400
401 ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
402 process_single_typemap( $typemap,
403 $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
404
405List of five elements: The individual typemap needing processing and four
406references.
407
408=item * Return Value
409
410List of four references -- modified versions of those passed in as arguments.
411
412=back
413
414=cut
415
bb5e8eb4
JK
416sub process_single_typemap {
417 my ($typemap,
418 $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = @_;
419 open my $TYPEMAP, '<', $typemap
420 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
421 my $mode = 'Typemap';
422 my $junk = "";
423 my $current = \$junk;
424 while (<$TYPEMAP>) {
425 # skip comments
426 next if /^\s*#/;
427 if (/^INPUT\s*$/) {
428 $mode = 'Input'; $current = \$junk; next;
429 }
430 if (/^OUTPUT\s*$/) {
431 $mode = 'Output'; $current = \$junk; next;
432 }
433 if (/^TYPEMAP\s*$/) {
434 $mode = 'Typemap'; $current = \$junk; next;
435 }
436 if ($mode eq 'Typemap') {
437 chomp;
438 my $logged_line = $_;
439 trim_whitespace($_);
440 # skip blank lines
441 next if /^$/;
442 my($type,$kind, $proto) =
0a4f6920 443 m/^\s*(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)\s*$/
bb5e8eb4
JK
444 or warn(
445 "Warning: File '$typemap' Line $. '$logged_line' " .
446 "TYPEMAP entry needs 2 or 3 columns\n"
447 ),
448 next;
449 $type = tidy_type($type);
450 $type_kind_ref->{$type} = $kind;
451 # prototype defaults to '$'
452 $proto = "\$" unless $proto;
bb5e8eb4
JK
453 $proto_letter_ref->{$type} = C_string($proto);
454 }
455 elsif (/^\s/) {
456 $$current .= $_;
457 }
458 elsif ($mode eq 'Input') {
459 s/\s+$//;
460 $input_expr_ref->{$_} = '';
461 $current = \$input_expr_ref->{$_};
462 }
463 else {
464 s/\s+$//;
465 $output_expr_ref->{$_} = '';
466 $current = \$output_expr_ref->{$_};
50b96cc2 467 }
50b96cc2 468 }
bb5e8eb4
JK
469 close $TYPEMAP;
470 return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
50b96cc2
JK
471}
472
af4112ab
JK
473=head2 C<make_targetable()>
474
475=over 4
476
477=item * Purpose
478
ddf4d752
JK
479Populate C<%targetable>. This constitutes a refinement of the output of
480C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>.
af4112ab
JK
481
482=item * Arguments
483
ddf4d752 484 %targetable = make_targetable($output_expr_ref);
af4112ab 485
ddf4d752 486Single hash reference: the fourth such ref returned by C<process_typemaps()>.
af4112ab
JK
487
488=item * Return Value
489
490Hash.
491
492=back
493
494=cut
495
496sub make_targetable {
497 my $output_expr_ref = shift;
498 my ($cast, $size);
499 our $bal;
500 $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
501 $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
502 $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
503
504 my %targetable;
505 foreach my $key (keys %{ $output_expr_ref }) {
506 # We can still bootstrap compile 're', because in code re.pm is
507 # available to miniperl, and does not attempt to load the XS code.
508 use re 'eval';
509
510 my ($t, $with_size, $arg, $sarg) =
511 ($output_expr_ref->{$key} =~
512 m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
513 \s* \( \s* $cast \$arg \s* ,
514 \s* ( (??{ $bal }) ) # Set from
515 ( (??{ $size }) )? # Possible sizeof set-from
516 \) \s* ; \s* $
517 ]x
518 );
519 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
520 }
521 return %targetable;
522}
523
361d4be6
JK
524=head2 C<map_type()>
525
526=over 4
527
528=item * Purpose
529
530Performs a mapping at several places inside C<PARAGRAPH> loop.
531
532=item * Arguments
533
534 $type = map_type($self, $type, $varname);
535
536List of three arguments.
537
538=item * Return Value
539
540String holding augmented version of second argument.
541
542=back
543
544=cut
545
0ec7450c 546sub map_type {
361d4be6 547 my ($self, $type, $varname) = @_;
0ec7450c
JK
548
549 # C++ has :: in types too so skip this
361d4be6 550 $type =~ tr/:/_/ unless $self->{hiertype};
0ec7450c
JK
551 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
552 if ($varname) {
553 if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
554 (substr $type, pos $type, 0) = " $varname ";
555 }
556 else {
557 $type .= "\t$varname";
558 }
559 }
560 return $type;
561}
562
361d4be6
JK
563=head2 C<standard_XS_defs()>
564
565=over 4
566
567=item * Purpose
568
569Writes to the C<.c> output file certain preprocessor directives and function
570headers needed in all such files.
571
572=item * Arguments
573
574None.
575
576=item * Return Value
577
578Implicitly returns true when final C<print> statement completes.
579
580=back
581
582=cut
583
6c2c48aa
JK
584sub standard_XS_defs {
585 print <<"EOF";
586#ifndef PERL_UNUSED_VAR
587# define PERL_UNUSED_VAR(var) if (0) var = var
588#endif
589
590EOF
591
592 print <<"EOF";
593#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
594#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
595
596/* prototype to pass -Wmissing-prototypes */
597STATIC void
598S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
599
600STATIC void
601S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
602{
603 const GV *const gv = CvGV(cv);
604
605 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
606
607 if (gv) {
608 const char *const gvname = GvNAME(gv);
609 const HV *const stash = GvSTASH(gv);
610 const char *const hvname = stash ? HvNAME(stash) : NULL;
611
612 if (hvname)
613 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
614 else
615 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
616 } else {
617 /* Pants. I don't think that it should be possible to get here. */
618 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
619 }
620}
621#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
622
623#ifdef PERL_IMPLICIT_CONTEXT
624#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
625#else
626#define croak_xs_usage S_croak_xs_usage
627#endif
628
629#endif
630
631/* NOTE: the prototype of newXSproto() is different in versions of perls,
632 * so we define a portable version of newXSproto()
633 */
634#ifdef newXS_flags
635#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
636#else
637#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
638#endif /* !defined(newXS_flags) */
639
640EOF
641}
642
361d4be6
JK
643=head2 C<assign_func_args()>
644
645=over 4
646
647=item * Purpose
648
649Perform assignment to the C<func_args> attribute.
650
651=item * Arguments
652
653 $string = assign_func_args($self, $argsref, $class);
654
655List of three elements. Second is an array reference; third is a string.
656
657=item * Return Value
658
659String.
660
661=back
662
663=cut
664
362926c8
JK
665sub assign_func_args {
666 my ($self, $argsref, $class) = @_;
667 my @func_args = @{$argsref};
668 shift @func_args if defined($class);
669
361d4be6
JK
670 for my $arg (@func_args) {
671 $arg =~ s/^/&/ if $self->{in_out}->{$arg};
362926c8
JK
672 }
673 return join(", ", @func_args);
674}
675
361d4be6
JK
676=head2 C<analyze_preprocessor_statements()>
677
678=over 4
679
680=item * Purpose
681
682Within each function inside each Xsub, print to the F<.c> output file certain
683preprocessor statements.
684
685=item * Arguments
686
687 ( $self, $XSS_work_idx, $BootCode_ref ) =
688 analyze_preprocessor_statements(
689 $self, $statement, $XSS_work_idx, $BootCode_ref
690 );
691
692List of four elements.
693
694=item * Return Value
695
696Modifed values of three of the arguments passed to the function. In
697particular, the C<XSStack> and C<InitFileCode> attributes are modified.
698
699=back
700
701=cut
702
703sub analyze_preprocessor_statements {
704 my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
1d3d7190 705
1d3d7190
JK
706 if ($statement eq 'if') {
707 $XSS_work_idx = @{ $self->{XSStack} };
708 push(@{ $self->{XSStack} }, {type => 'if'});
709 }
710 else {
711 death ("Error: `$statement' with no matching `if'")
712 if $self->{XSStack}->[-1]{type} ne 'if';
713 if ($self->{XSStack}->[-1]{varname}) {
714 push(@{ $self->{InitFileCode} }, "#endif\n");
715 push(@{ $BootCode_ref }, "#endif");
716 }
717
718 my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
719 if ($statement ne 'endif') {
720 # Hide the functions defined in other #if branches, and reset.
721 @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
722 @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
723 }
724 else {
725 my($tmp) = pop(@{ $self->{XSStack} });
726 0 while (--$XSS_work_idx
727 && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
728 # Keep all new defined functions
729 push(@fns, keys %{$tmp->{other_functions}});
730 @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
731 }
732 }
733 return ($self, $XSS_work_idx, $BootCode_ref);
734}
735
361d4be6
JK
736=head2 C<set_cond()>
737
738=over 4
739
740=item * Purpose
741
742=item * Arguments
743
744=item * Return Value
745
746=back
747
748=cut
749
40a3ae2f
JK
750sub set_cond {
751 my ($ellipsis, $min_args, $num_args) = @_;
752 my $cond;
753 if ($ellipsis) {
754 $cond = ($min_args ? qq(items < $min_args) : 0);
755 }
756 elsif ($min_args == $num_args) {
757 $cond = qq(items != $min_args);
758 }
759 else {
760 $cond = qq(items < $min_args || items > $num_args);
761 }
762 return $cond;
763}
764
361d4be6
JK
765=head2 C<Warn()>
766
767=over 4
768
769=item * Purpose
770
771=item * Arguments
772
773=item * Return Value
774
775=back
776
777=cut
778
2a09a23f
JK
779sub Warn {
780 my $self = shift;
781 # work out the line number
782 my $warn_line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
783
784 print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
785}
786
361d4be6
JK
787=head2 C<blurt()>
788
789=over 4
790
791=item * Purpose
792
793=item * Arguments
794
795=item * Return Value
796
797=back
798
799=cut
800
2a09a23f
JK
801sub blurt {
802 my $self = shift;
803 Warn($self, @_);
804 $self->{errors}++
805}
806
361d4be6
JK
807=head2 C<death()>
808
809=over 4
810
811=item * Purpose
812
813=item * Arguments
814
815=item * Return Value
816
817=back
818
819=cut
820
2a09a23f
JK
821sub death {
822 my $self = shift;
823 Warn($self, @_);
824 exit 1;
825}
826
361d4be6
JK
827=head2 C<check_conditional_preprocessor_statements()>
828
829=over 4
830
831=item * Purpose
832
833=item * Arguments
834
835=item * Return Value
836
837=back
838
839=cut
840
2a09a23f
JK
841sub check_conditional_preprocessor_statements {
842 my ($self) = @_;
843 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
844 if (@cpp) {
845 my $cpplevel;
846 for my $cpp (@cpp) {
847 if ($cpp =~ /^\#\s*if/) {
848 $cpplevel++;
849 }
850 elsif (!$cpplevel) {
851 Warn( $self, "Warning: #else/elif/endif without #if in this function");
852 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
853 if $self->{XSStack}->[-1]{type} eq 'if';
854 return;
855 }
856 elsif ($cpp =~ /^\#\s*endif/) {
857 $cpplevel--;
858 }
859 }
860 Warn( $self, "Warning: #if without #endif in this function") if $cpplevel;
861 }
862}
e6de4093 863
a65c06db 8641;
27b7514f
JK
865
866# vim: ts=2 sw=2 et: