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 require ExtUtils::Typemaps;
   9
  10 our (@ISA, @EXPORT_OK);
  11 @ISA = qw(Exporter);
  12 @EXPORT_OK = qw(
  13   standard_typemap_locations
  14   trim_whitespace
  15   tidy_type
  16   C_string
  17   valid_proto_string
  18   process_typemaps
  19   process_single_typemap
  20   make_targetable
  21   map_type
  22   standard_XS_defs
  23   assign_func_args
  24   analyze_preprocessor_statements
  25   set_cond
  26   Warn
  27   blurt
  28   death
  29   check_conditional_preprocessor_statements
  30 );
  31
  32 =head1 NAME
  33
  34 ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS
  35
  36 =head1 SYNOPSIS
  37
  38   use ExtUtils::ParseXS::Utilities qw(
  39     standard_typemap_locations
  40     trim_whitespace
  41     tidy_type
  42     C_string
  43     valid_proto_string
  44     process_typemaps
  45     process_single_typemap
  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 ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
 285     process_typemaps( $args{typemap}, $pwd );
 286
 287 List of two elements:  C<typemap> element from C<%args>; current working
 288 directory.
 289
 290 =item * Return Value
 291
 292 Upon success, returns a list of four hash references.  (This will probably be
 293 refactored.)  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
 308 Keys:  C types.  Values:  XS types identifiers
 309
 310 =item * C<$proto_letter_ref>
 311
 312   {
 313     'char **' => '$',
 314     'bool_t' => '$',
 315     'AV *' => '$',
 316     'InputStream' => '$',
 317     'double' => '$',
 318     # ...
 319   }
 320
 321 Keys: 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
 334 Keys:  XS typemap identifiers.  Values:  Newline-terminated strings that
 335 will be written to C source code (F<.c>) files.   The strings are C code, but
 336 with Perl variables whose values will be interpolated at F<xsubpp>'s runtime
 337 by 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
 356 Keys:  XS typemap identifiers.  Values:  Newline-terminated strings that
 357 will be written to C source code (F<.c>) files.   The strings are C code, but
 358 with Perl variables whose values will be interpolated at F<xsubpp>'s runtime
 359 by one of the C<eval EXPR> statements in ExtUtils::ParseXS.
 360
 361 =back
 362
 363 =back
 364
 365 =cut
 366
 367 sub 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
 378   my $typemap = ExtUtils::Typemaps->new;
 379   foreach my $typemap_loc (@tm) {
 380     next unless -f $typemap_loc;
 381     # skip directories, binary files etc.
 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);
 386   }
 387
 388   return (
 389     $typemap->_get_typemap_hash(),
 390     $typemap->_get_prototype_hash(),
 391     $typemap->_get_inputmap_hash(),
 392     $typemap->_get_outputmap_hash(),
 393   );
 394 }
 395
 396 =head2 C<process_single_typemap()>
 397
 398 =over 4
 399
 400 =item * Purpose
 401
 402 Process 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
 410 List of five elements:  The individual typemap needing processing and four
 411 references.
 412
 413 =item * Return Value
 414
 415 List of four references -- modified versions of those passed in as arguments.
 416
 417 =back
 418
 419 =cut
 420
 421 sub 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) =
 448         m/^\s*(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)\s*$/
 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;
 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->{$_};
 472     }
 473   }
 474   close $TYPEMAP;
 475   return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref);
 476 }
 477
 478 =head2 C<make_targetable()>
 479
 480 =over 4
 481
 482 =item * Purpose
 483
 484 Populate C<%targetable>.  This constitutes a refinement of the output of
 485 C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>.
 486
 487 =item * Arguments
 488
 489   %targetable = make_targetable($output_expr_ref);
 490
 491 Single hash reference:  the fourth such ref returned by C<process_typemaps()>.
 492
 493 =item * Return Value
 494
 495 Hash.
 496
 497 =back
 498
 499 =cut
 500
 501 sub make_targetable {
 502   my $output_expr_ref = shift;
 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;
 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
 530     my ($type, $with_size, $arg, $sarg) =
 531       ($output_expr_ref->{$key} =~
 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
 539           ( (??{ $size }) )?    # Possible sizeof set-from
 540           \) \s* ; \s* $
 541         ]x
 542     );
 543     $targetable{$key} = [$type, $with_size, $arg, $sarg] if $type;
 544   }
 545   return %targetable;
 546 }
 547
 548 =head2 C<map_type()>
 549
 550 =over 4
 551
 552 =item * Purpose
 553
 554 Performs a mapping at several places inside C<PARAGRAPH> loop.
 555
 556 =item * Arguments
 557
 558   $type = map_type($self, $type, $varname);
 559
 560 List of three arguments.
 561
 562 =item * Return Value
 563
 564 String holding augmented version of second argument.
 565
 566 =back
 567
 568 =cut
 569
 570 sub map_type {
 571   my ($self, $type, $varname) = @_;
 572
 573   # C++ has :: in types too so skip this
 574   $type =~ tr/:/_/ unless $self->{hiertype};
 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
 587 =head2 C<standard_XS_defs()>
 588
 589 =over 4
 590
 591 =item * Purpose
 592
 593 Writes to the C<.c> output file certain preprocessor directives and function
 594 headers needed in all such files.
 595
 596 =item * Arguments
 597
 598 None.
 599
 600 =item * Return Value
 601
 602 Implicitly returns true when final C<print> statement completes.
 603
 604 =back
 605
 606 =cut
 607
 608 sub standard_XS_defs {
 609   print <<"EOF";
 610 #ifndef PERL_UNUSED_VAR
 611 #  define PERL_UNUSED_VAR(var) if (0) var = var
 612 #endif
 613
 614 EOF
 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 */
 621 STATIC void
 622 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
 623
 624 STATIC void
 625 S_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
 664 EOF
 665 }
 666
 667 =head2 C<assign_func_args()>
 668
 669 =over 4
 670
 671 =item * Purpose
 672
 673 Perform assignment to the C<func_args> attribute.
 674
 675 =item * Arguments
 676
 677   $string = assign_func_args($self, $argsref, $class);
 678
 679 List of three elements.  Second is an array reference; third is a string.
 680
 681 =item * Return Value
 682
 683 String.
 684
 685 =back
 686
 687 =cut
 688
 689 sub assign_func_args {
 690   my ($self, $argsref, $class) = @_;
 691   my @func_args = @{$argsref};
 692   shift @func_args if defined($class);
 693
 694   for my $arg (@func_args) {
 695     $arg =~ s/^/&/ if $self->{in_out}->{$arg};
 696   }
 697   return join(", ", @func_args);
 698 }
 699
 700 =head2 C<analyze_preprocessor_statements()>
 701
 702 =over 4
 703
 704 =item * Purpose
 705
 706 Within each function inside each Xsub, print to the F<.c> output file certain
 707 preprocessor 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
 716 List of four elements.
 717
 718 =item * Return Value
 719
 720 Modifed values of three of the arguments passed to the function.  In
 721 particular, the C<XSStack> and C<InitFileCode> attributes are modified.
 722
 723 =back
 724
 725 =cut
 726
 727 sub analyze_preprocessor_statements {
 728   my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
 729
 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
 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
 774 sub 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
 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
 803 sub 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
 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
 825 sub blurt {
 826   my $self = shift;
 827   Warn($self, @_);
 828   $self->{errors}++
 829 }
 830
 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
 845 sub death {
 846   my $self = shift;
 847   Warn($self, @_);
 848   exit 1;
 849 }
 850
 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
 865 sub 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 }
 887
 888 1;
 889
 890 # vim: ts=2 sw=2 et: