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