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