dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm

   1 package ExtUtils::ParseXS::Utilities;
   2 use strict;
   3 use warnings;
   4 use Exporter;
   5 use File::Spec;
   6 use lib qw( lib );
   7 use ExtUtils::ParseXS::Constants ();
   8
   9 our $VERSION = '3.05';
  10
  11 our (@ISA, @EXPORT_OK);
  12 @ISA = qw(Exporter);
  13 @EXPORT_OK = qw(
  14   standard_typemap_locations
  15   trim_whitespace
  16   tidy_type
  17   C_string
  18   valid_proto_string
  19   process_typemaps
  20   make_targetable
  21   map_type
  22   standard_XS_defs
  23   assign_func_args
  24   analyze_preprocessor_statements
  25   set_cond
  26   Warn
  27   current_line_number
  28   blurt
  29   death
  30   check_conditional_preprocessor_statements
  31 );
  32
  33 =head1 NAME
  34
  35 ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS
  36
  37 =head1 SYNOPSIS
  38
  39   use ExtUtils::ParseXS::Utilities qw(
  40     standard_typemap_locations
  41     trim_whitespace
  42     tidy_type
  43     C_string
  44     valid_proto_string
  45     process_typemaps
  46     make_targetable
  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
  56   );
  57
  58 =head1 SUBROUTINES
  59
  60 The following functions are not considered to be part of the public interface.
  61 They 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
  69 Provide a list of filepaths where F<typemap> files may be found.  The
  70 filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority.
  71
  72 The highest priority is to look in the current directory.
  73
  74   'typemap'
  75
  76 The second and third highest priorities are to look in the parent of the
  77 current directory and a directory called F<lib/ExtUtils> underneath the parent
  78 directory.
  79
  80   '../typemap',
  81   '../lib/ExtUtils/typemap',
  82
  83 The fourth through ninth highest priorities are to look in the corresponding
  84 grandparent, 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
  93 The tenth and subsequent priorities are to look in directories named
  94 F<ExtUtils> which are subdirectories of directories found in C<@INC> --
  95 I<provided> a file named F<typemap> actually exists in such a directory.
  96 Example:
  97
  98   '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
  99
 100 However, these filepaths appear in the list returned by
 101 C<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
 118 Reference to C<@INC>.
 119
 120 =item * Return Value
 121
 122 Array holding list of directories to be searched for F<typemap> files.
 123
 124 =back
 125
 126 =cut
 127
 128 sub standard_typemap_locations {
 129   my $include_ref = shift;
 130   my @tm = qw(typemap);
 131
 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   ) {
 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
 149 =head2 C<trim_whitespace()>
 150
 151 =over 4
 152
 153 =item * Purpose
 154
 155 Perform an in-place trimming of leading and trailing whitespace from the
 156 first argument provided to the function.
 157
 158 =item * Argument
 159
 160   trim_whitespace($arg);
 161
 162 =item * Return Value
 163
 164 None.  Remember:  this is an I<in-place> modification of the argument.
 165
 166 =back
 167
 168 =cut
 169
 170 sub trim_whitespace {
 171   $_[0] =~ s/^\s+|\s+$//go;
 172 }
 173
 174 =head2 C<tidy_type()>
 175
 176 =over 4
 177
 178 =item * Purpose
 179
 180 Rationalize any asterisks (C<*>) by joining them into bunches, removing
 181 interior whitespace, then trimming leading and trailing whitespace.
 182
 183 =item * Arguments
 184
 185     ($ret_type) = tidy_type($_);
 186
 187 String to be cleaned up.
 188
 189 =item * Return Value
 190
 191 String cleaned up.
 192
 193 =back
 194
 195 =cut
 196
 197 sub 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
 213 =head2 C<C_string()>
 214
 215 =over 4
 216
 217 =item * Purpose
 218
 219 Escape backslashes (C<\>) in prototype strings.
 220
 221 =item * Arguments
 222
 223       $ProtoThisXSUB = C_string($_);
 224
 225 String needing escaping.
 226
 227 =item * Return Value
 228
 229 Properly escaped string.
 230
 231 =back
 232
 233 =cut
 234
 235 sub C_string {
 236   my($string) = @_;
 237
 238   $string =~ s[\\][\\\\]g;
 239   $string;
 240 }
 241
 242 =head2 C<valid_proto_string()>
 243
 244 =over 4
 245
 246 =item * Purpose
 247
 248 Validate prototype string.
 249
 250 =item * Arguments
 251
 252 String needing checking.
 253
 254 =item * Return Value
 255
 256 Upon success, returns the same string passed as argument.
 257
 258 Upon failure, returns C<0>.
 259
 260 =back
 261
 262 =cut
 263
 264 sub valid_proto_string {
 265   my($string) = @_;
 266
 267   if ( $string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/ ) {
 268     return $string;
 269   }
 270
 271   return 0;
 272 }
 273
 274 =head2 C<process_typemaps()>
 275
 276 =over 4
 277
 278 =item * Purpose
 279
 280 Process all typemap files.
 281
 282 =item * Arguments
 283
 284   my $typemaps_object = process_typemaps( $args{typemap}, $pwd );
 285
 286 List of two elements:  C<typemap> element from C<%args>; current working
 287 directory.
 288
 289 =item * Return Value
 290
 291 Upon success, returns an L<ExtUtils::Typemaps> object.
 292
 293 =back
 294
 295 =cut
 296
 297 sub 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
 308   require ExtUtils::Typemaps;
 309   my $typemap = ExtUtils::Typemaps->new;
 310   foreach my $typemap_loc (@tm) {
 311     next unless -f $typemap_loc;
 312     # skip directories, binary files etc.
 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);
 317   }
 318
 319   return $typemap;
 320 }
 321
 322 =head2 C<make_targetable()>
 323
 324 =over 4
 325
 326 =item * Purpose
 327
 328 Populate C<%targetable>.  This constitutes a refinement of the output of
 329 C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>.
 330
 331 =item * Arguments
 332
 333   %targetable = make_targetable($output_expr_ref);
 334
 335 Single hash reference:  the fourth such ref returned by C<process_typemaps()>.
 336
 337 =item * Return Value
 338
 339 Hash.
 340
 341 =back
 342
 343 =cut
 344
 345 sub make_targetable {
 346   my $output_expr_ref = shift;
 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;
 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
 374     my ($type, $with_size, $arg, $sarg) =
 375       ($output_expr_ref->{$key} =~
 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
 383           ( (??{ $size }) )?    # Possible sizeof set-from
 384           \) \s* ; \s* $
 385         ]x
 386     );
 387     $targetable{$key} = [$type, $with_size, $arg, $sarg] if $type;
 388   }
 389   return %targetable;
 390 }
 391
 392 =head2 C<map_type()>
 393
 394 =over 4
 395
 396 =item * Purpose
 397
 398 Performs a mapping at several places inside C<PARAGRAPH> loop.
 399
 400 =item * Arguments
 401
 402   $type = map_type($self, $type, $varname);
 403
 404 List of three arguments.
 405
 406 =item * Return Value
 407
 408 String holding augmented version of second argument.
 409
 410 =back
 411
 412 =cut
 413
 414 sub map_type {
 415   my ($self, $type, $varname) = @_;
 416
 417   # C++ has :: in types too so skip this
 418   $type =~ tr/:/_/ unless $self->{hiertype};
 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
 431 =head2 C<standard_XS_defs()>
 432
 433 =over 4
 434
 435 =item * Purpose
 436
 437 Writes to the C<.c> output file certain preprocessor directives and function
 438 headers needed in all such files.
 439
 440 =item * Arguments
 441
 442 None.
 443
 444 =item * Return Value
 445
 446 Returns true.
 447
 448 =back
 449
 450 =cut
 451
 452 sub standard_XS_defs {
 453   print <<"EOF";
 454 #ifndef PERL_UNUSED_VAR
 455 #  define PERL_UNUSED_VAR(var) if (0) var = var
 456 #endif
 457
 458 #ifndef dVAR
 459 #  define dVAR          dNOOP
 460 #endif
 461
 462
 463 /* This stuff is not part of the API! You have been warned. */
 464 #ifndef PERL_VERSION_DECIMAL
 465 #  define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
 466 #endif
 467 #ifndef PERL_DECIMAL_VERSION
 468 #  define PERL_DECIMAL_VERSION \\
 469           PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
 470 #endif
 471 #ifndef PERL_VERSION_GE
 472 #  define PERL_VERSION_GE(r,v,s) \\
 473           (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
 474 #endif
 475 #ifndef PERL_VERSION_LE
 476 #  define PERL_VERSION_LE(r,v,s) \\
 477           (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
 478 #endif
 479
 480 /* XS_INTERNAL is the explicit static-linkage variant of the default
 481  * XS macro.
 482  *
 483  * XS_EXTERNAL is the same as XS_INTERNAL except it does not include
 484  * "STATIC", ie. it exports XSUB symbols. You probably don't want that
 485  * for anything but the BOOT XSUB.
 486  *
 487  * See XSUB.h in core!
 488  */
 489
 490
 491 /* TODO: This might be compatible further back than 5.10.0. */
 492 #if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1)
 493 #  undef XS_EXTERNAL
 494 #  undef XS_INTERNAL
 495 #  if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING)
 496 #    define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name)
 497 #    define XS_INTERNAL(name) __declspec(dllexport) STATIC XSPROTO(name)
 498 #  endif
 499 #  if defined(__SYMBIAN32__)
 500 #    define XS_EXTERNAL(name) EXPORT_C XSPROTO(name)
 501 #    define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name)
 502 #  endif
 503 #  ifndef XS_EXTERNAL
 504 #    if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus)
 505 #      define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__)
 506 #      define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__)
 507 #    else
 508 #      ifdef __cplusplus
 509 #        define XS_EXTERNAL(name) extern "C" XSPROTO(name)
 510 #        define XS_INTERNAL(name) static XSPROTO(name)
 511 #      else
 512 #        define XS_EXTERNAL(name) XSPROTO(name)
 513 #        define XS_INTERNAL(name) STATIC XSPROTO(name)
 514 #      endif
 515 #    endif
 516 #  endif
 517 #endif
 518
 519 /* perl >= 5.10.0 && perl <= 5.15.1 */
 520
 521
 522 /* The XS_EXTERNAL macro is used for functions that must not be static
 523  * like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL
 524  * macro defined, the best we can do is assume XS is the same.
 525  * Dito for XS_INTERNAL.
 526  */
 527 #ifndef XS_EXTERNAL
 528 #  define XS_EXTERNAL(name) XS(name)
 529 #endif
 530 #ifndef XS_INTERNAL
 531 #  define XS_INTERNAL(name) XS(name)
 532 #endif
 533
 534 /* Now, finally, after all this mess, we want an ExtUtils::ParseXS
 535  * internal macro that we're free to redefine for varying linkage due
 536  * to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use
 537  * XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to!
 538  */
 539
 540 #undef XS_EUPXS
 541 #if defined(PERL_EUPXS_ALWAYS_EXPORT)
 542 #  define XS_EUPXS(name) XS_EXTERNAL(name)
 543 #else
 544    /* default to internal */
 545 #  define XS_EUPXS(name) XS_INTERNAL(name)
 546 #endif
 547
 548 EOF
 549
 550   print <<"EOF";
 551 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
 552 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
 553
 554 /* prototype to pass -Wmissing-prototypes */
 555 STATIC void
 556 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
 557
 558 STATIC void
 559 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
 560 {
 561     const GV *const gv = CvGV(cv);
 562
 563     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 564
 565     if (gv) {
 566         const char *const gvname = GvNAME(gv);
 567         const HV *const stash = GvSTASH(gv);
 568         const char *const hvname = stash ? HvNAME(stash) : NULL;
 569
 570         if (hvname)
 571             Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
 572         else
 573             Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
 574     } else {
 575         /* Pants. I don't think that it should be possible to get here. */
 576         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
 577     }
 578 }
 579 #undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE
 580
 581 #ifdef PERL_IMPLICIT_CONTEXT
 582 #define croak_xs_usage(a,b)    S_croak_xs_usage(aTHX_ a,b)
 583 #else
 584 #define croak_xs_usage        S_croak_xs_usage
 585 #endif
 586
 587 #endif
 588
 589 /* NOTE: the prototype of newXSproto() is different in versions of perls,
 590  * so we define a portable version of newXSproto()
 591  */
 592 #ifdef newXS_flags
 593 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
 594 #else
 595 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
 596 #endif /* !defined(newXS_flags) */
 597
 598 EOF
 599   return 1;
 600 }
 601
 602 =head2 C<assign_func_args()>
 603
 604 =over 4
 605
 606 =item * Purpose
 607
 608 Perform assignment to the C<func_args> attribute.
 609
 610 =item * Arguments
 611
 612   $string = assign_func_args($self, $argsref, $class);
 613
 614 List of three elements.  Second is an array reference; third is a string.
 615
 616 =item * Return Value
 617
 618 String.
 619
 620 =back
 621
 622 =cut
 623
 624 sub assign_func_args {
 625   my ($self, $argsref, $class) = @_;
 626   my @func_args = @{$argsref};
 627   shift @func_args if defined($class);
 628
 629   for my $arg (@func_args) {
 630     $arg =~ s/^/&/ if $self->{in_out}->{$arg};
 631   }
 632   return join(", ", @func_args);
 633 }
 634
 635 =head2 C<analyze_preprocessor_statements()>
 636
 637 =over 4
 638
 639 =item * Purpose
 640
 641 Within each function inside each Xsub, print to the F<.c> output file certain
 642 preprocessor statements.
 643
 644 =item * Arguments
 645
 646       ( $self, $XSS_work_idx, $BootCode_ref ) =
 647         analyze_preprocessor_statements(
 648           $self, $statement, $XSS_work_idx, $BootCode_ref
 649         );
 650
 651 List of four elements.
 652
 653 =item * Return Value
 654
 655 Modifed values of three of the arguments passed to the function.  In
 656 particular, the C<XSStack> and C<InitFileCode> attributes are modified.
 657
 658 =back
 659
 660 =cut
 661
 662 sub analyze_preprocessor_statements {
 663   my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
 664
 665   if ($statement eq 'if') {
 666     $XSS_work_idx = @{ $self->{XSStack} };
 667     push(@{ $self->{XSStack} }, {type => 'if'});
 668   }
 669   else {
 670     $self->death("Error: '$statement' with no matching 'if'")
 671       if $self->{XSStack}->[-1]{type} ne 'if';
 672     if ($self->{XSStack}->[-1]{varname}) {
 673       push(@{ $self->{InitFileCode} }, "#endif\n");
 674       push(@{ $BootCode_ref },     "#endif");
 675     }
 676
 677     my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
 678     if ($statement ne 'endif') {
 679       # Hide the functions defined in other #if branches, and reset.
 680       @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
 681       @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
 682     }
 683     else {
 684       my($tmp) = pop(@{ $self->{XSStack} });
 685       0 while (--$XSS_work_idx
 686            && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
 687       # Keep all new defined functions
 688       push(@fns, keys %{$tmp->{other_functions}});
 689       @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
 690     }
 691   }
 692   return ($self, $XSS_work_idx, $BootCode_ref);
 693 }
 694
 695 =head2 C<set_cond()>
 696
 697 =over 4
 698
 699 =item * Purpose
 700
 701 =item * Arguments
 702
 703 =item * Return Value
 704
 705 =back
 706
 707 =cut
 708
 709 sub set_cond {
 710   my ($ellipsis, $min_args, $num_args) = @_;
 711   my $cond;
 712   if ($ellipsis) {
 713     $cond = ($min_args ? qq(items < $min_args) : 0);
 714   }
 715   elsif ($min_args == $num_args) {
 716     $cond = qq(items != $min_args);
 717   }
 718   else {
 719     $cond = qq(items < $min_args || items > $num_args);
 720   }
 721   return $cond;
 722 }
 723
 724 =head2 C<current_line_number()>
 725
 726 =over 4
 727
 728 =item * Purpose
 729
 730 Figures out the current line number in the XS file.
 731
 732 =item * Arguments
 733
 734 C<$self>
 735
 736 =item * Return Value
 737
 738 The current line number.
 739
 740 =back
 741
 742 =cut
 743
 744 sub current_line_number {
 745   my $self = shift;
 746   my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
 747   return $line_number;
 748 }
 749
 750 =head2 C<Warn()>
 751
 752 =over 4
 753
 754 =item * Purpose
 755
 756 =item * Arguments
 757
 758 =item * Return Value
 759
 760 =back
 761
 762 =cut
 763
 764 sub Warn {
 765   my $self = shift;
 766   my $warn_line_number = $self->current_line_number();
 767   print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
 768 }
 769
 770 =head2 C<blurt()>
 771
 772 =over 4
 773
 774 =item * Purpose
 775
 776 =item * Arguments
 777
 778 =item * Return Value
 779
 780 =back
 781
 782 =cut
 783
 784 sub blurt {
 785   my $self = shift;
 786   $self->Warn(@_);
 787   $self->{errors}++
 788 }
 789
 790 =head2 C<death()>
 791
 792 =over 4
 793
 794 =item * Purpose
 795
 796 =item * Arguments
 797
 798 =item * Return Value
 799
 800 =back
 801
 802 =cut
 803
 804 sub death {
 805   my $self = shift;
 806   $self->Warn(@_);
 807   exit 1;
 808 }
 809
 810 =head2 C<check_conditional_preprocessor_statements()>
 811
 812 =over 4
 813
 814 =item * Purpose
 815
 816 =item * Arguments
 817
 818 =item * Return Value
 819
 820 =back
 821
 822 =cut
 823
 824 sub check_conditional_preprocessor_statements {
 825   my ($self) = @_;
 826   my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
 827   if (@cpp) {
 828     my $cpplevel;
 829     for my $cpp (@cpp) {
 830       if ($cpp =~ /^\#\s*if/) {
 831         $cpplevel++;
 832       }
 833       elsif (!$cpplevel) {
 834         $self->Warn("Warning: #else/elif/endif without #if in this function");
 835         print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
 836           if $self->{XSStack}->[-1]{type} eq 'if';
 837         return;
 838       }
 839       elsif ($cpp =~ /^\#\s*endif/) {
 840         $cpplevel--;
 841       }
 842     }
 843     $self->Warn("Warning: #if without #endif in this function") if $cpplevel;
 844   }
 845 }
 846
 847 1;
 848
 849 # vim: ts=2 sw=2 et: