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 (@ISA, @EXPORT_OK);
  10 @ISA = qw(Exporter);
  11 @EXPORT_OK = qw(
  12   standard_typemap_locations
  13   trim_whitespace
  14   tidy_type
  15   C_string
  16   valid_proto_string
  17   process_typemaps
  18   make_targetable
  19   map_type
  20   standard_XS_defs
  21   assign_func_args
  22   analyze_preprocessor_statements
  23   set_cond
  24   Warn
  25   current_line_number
  26   blurt
  27   death
  28   check_conditional_preprocessor_statements
  29 );
  30
  31 =head1 NAME
  32
  33 ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS
  34
  35 =head1 SYNOPSIS
  36
  37   use ExtUtils::ParseXS::Utilities qw(
  38     standard_typemap_locations
  39     trim_whitespace
  40     tidy_type
  41     C_string
  42     valid_proto_string
  43     process_typemaps
  44     make_targetable
  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
  54   );
  55
  56 =head1 SUBROUTINES
  57
  58 The following functions are not considered to be part of the public interface.
  59 They 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
  67 Provide a list of filepaths where F<typemap> files may be found.  The
  68 filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority.
  69
  70 The highest priority is to look in the current directory.
  71
  72   'typemap'
  73
  74 The second and third highest priorities are to look in the parent of the
  75 current directory and a directory called F<lib/ExtUtils> underneath the parent
  76 directory.
  77
  78   '../typemap',
  79   '../lib/ExtUtils/typemap',
  80
  81 The fourth through ninth highest priorities are to look in the corresponding
  82 grandparent, 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
  91 The tenth and subsequent priorities are to look in directories named
  92 F<ExtUtils> which are subdirectories of directories found in C<@INC> --
  93 I<provided> a file named F<typemap> actually exists in such a directory.
  94 Example:
  95
  96   '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap',
  97
  98 However, these filepaths appear in the list returned by
  99 C<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
 116 Reference to C<@INC>.
 117
 118 =item * Return Value
 119
 120 Array holding list of directories to be searched for F<typemap> files.
 121
 122 =back
 123
 124 =cut
 125
 126 sub standard_typemap_locations {
 127   my $include_ref = shift;
 128   my @tm = qw(typemap);
 129
 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   ) {
 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
 147 =head2 C<trim_whitespace()>
 148
 149 =over 4
 150
 151 =item * Purpose
 152
 153 Perform an in-place trimming of leading and trailing whitespace from the
 154 first argument provided to the function.
 155
 156 =item * Argument
 157
 158   trim_whitespace($arg);
 159
 160 =item * Return Value
 161
 162 None.  Remember:  this is an I<in-place> modification of the argument.
 163
 164 =back
 165
 166 =cut
 167
 168 sub trim_whitespace {
 169   $_[0] =~ s/^\s+|\s+$//go;
 170 }
 171
 172 =head2 C<tidy_type()>
 173
 174 =over 4
 175
 176 =item * Purpose
 177
 178 Rationalize any asterisks (C<*>) by joining them into bunches, removing
 179 interior whitespace, then trimming leading and trailing whitespace.
 180
 181 =item * Arguments
 182
 183     ($ret_type) = tidy_type($_);
 184
 185 String to be cleaned up.
 186
 187 =item * Return Value
 188
 189 String cleaned up.
 190
 191 =back
 192
 193 =cut
 194
 195 sub 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
 211 =head2 C<C_string()>
 212
 213 =over 4
 214
 215 =item * Purpose
 216
 217 Escape backslashes (C<\>) in prototype strings.
 218
 219 =item * Arguments
 220
 221       $ProtoThisXSUB = C_string($_);
 222
 223 String needing escaping.
 224
 225 =item * Return Value
 226
 227 Properly escaped string.
 228
 229 =back
 230
 231 =cut
 232
 233 sub C_string {
 234   my($string) = @_;
 235
 236   $string =~ s[\\][\\\\]g;
 237   $string;
 238 }
 239
 240 =head2 C<valid_proto_string()>
 241
 242 =over 4
 243
 244 =item * Purpose
 245
 246 Validate prototype string.
 247
 248 =item * Arguments
 249
 250 String needing checking.
 251
 252 =item * Return Value
 253
 254 Upon success, returns the same string passed as argument.
 255
 256 Upon failure, returns C<0>.
 257
 258 =back
 259
 260 =cut
 261
 262 sub valid_proto_string {
 263   my($string) = @_;
 264
 265   if ( $string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/ ) {
 266     return $string;
 267   }
 268
 269   return 0;
 270 }
 271
 272 =head2 C<process_typemaps()>
 273
 274 =over 4
 275
 276 =item * Purpose
 277
 278 Process all typemap files.
 279
 280 =item * Arguments
 281
 282   my $typemaps_object = process_typemaps( $args{typemap}, $pwd );
 283
 284 List of two elements:  C<typemap> element from C<%args>; current working
 285 directory.
 286
 287 =item * Return Value
 288
 289 Upon success, returns an L<ExtUtils::Typemaps> object.
 290
 291 =back
 292
 293 =cut
 294
 295 sub process_typemaps {
 296   my ($tmap, $pwd) = @_;
 297
 298   my @tm = ref $tmap ? @{$tmap} : ($tmap);
 299
 300   foreach my $typemap (@tm) {
 301     die "Can't find $typemap in $pwd\n" unless -r $typemap;
 302   }
 303
 304   push @tm, standard_typemap_locations( \@INC );
 305
 306   require ExtUtils::Typemaps;
 307   my $typemap = ExtUtils::Typemaps->new;
 308   foreach my $typemap_loc (@tm) {
 309     next unless -f $typemap_loc;
 310     # skip directories, binary files etc.
 311     warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"), next
 312       unless -T $typemap_loc;
 313
 314     $typemap->merge(file => $typemap_loc, replace => 1);
 315   }
 316
 317   return $typemap;
 318 }
 319
 320 =head2 C<make_targetable()>
 321
 322 =over 4
 323
 324 =item * Purpose
 325
 326 Populate C<%targetable>.  This constitutes a refinement of the output of
 327 C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>.
 328
 329 =item * Arguments
 330
 331   %targetable = make_targetable($output_expr_ref);
 332
 333 Single hash reference:  the fourth such ref returned by C<process_typemaps()>.
 334
 335 =item * Return Value
 336
 337 Hash.
 338
 339 =back
 340
 341 =cut
 342
 343 sub make_targetable {
 344   my $output_expr_ref = shift;
 345
 346   our $bal; # ()-balanced
 347   $bal = qr[
 348     (?:
 349       (?>[^()]+)
 350       |
 351       \( (??{ $bal }) \)
 352     )*
 353   ]x;
 354
 355   # matches variations on (SV*)
 356   my $sv_cast = qr[
 357     (?:
 358       \( \s* SV \s* \* \s* \) \s*
 359     )?
 360   ]x;
 361
 362   my $size = qr[ # Third arg (to setpvn)
 363     , \s* (??{ $bal })
 364   ]x;
 365
 366   my %targetable;
 367   foreach my $key (keys %{ $output_expr_ref }) {
 368     # We can still bootstrap compile 're', because in code re.pm is
 369     # available to miniperl, and does not attempt to load the XS code.
 370     use re 'eval';
 371
 372     my ($type, $with_size, $arg, $sarg) =
 373       ($output_expr_ref->{$key} =~
 374         m[^
 375           \s+
 376           sv_set([iunp])v(n)?    # Type, is_setpvn
 377           \s*
 378           \( \s*
 379             $sv_cast \$arg \s* , \s*
 380             ( (??{ $bal }) )    # Set from
 381           ( (??{ $size }) )?    # Possible sizeof set-from
 382           \) \s* ; \s* $
 383         ]x
 384     );
 385     $targetable{$key} = [$type, $with_size, $arg, $sarg] if $type;
 386   }
 387   return %targetable;
 388 }
 389
 390 =head2 C<map_type()>
 391
 392 =over 4
 393
 394 =item * Purpose
 395
 396 Performs a mapping at several places inside C<PARAGRAPH> loop.
 397
 398 =item * Arguments
 399
 400   $type = map_type($self, $type, $varname);
 401
 402 List of three arguments.
 403
 404 =item * Return Value
 405
 406 String holding augmented version of second argument.
 407
 408 =back
 409
 410 =cut
 411
 412 sub map_type {
 413   my ($self, $type, $varname) = @_;
 414
 415   # C++ has :: in types too so skip this
 416   $type =~ tr/:/_/ unless $self->{hiertype};
 417   $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
 418   if ($varname) {
 419     if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
 420       (substr $type, pos $type, 0) = " $varname ";
 421     }
 422     else {
 423       $type .= "\t$varname";
 424     }
 425   }
 426   return $type;
 427 }
 428
 429 =head2 C<standard_XS_defs()>
 430
 431 =over 4
 432
 433 =item * Purpose
 434
 435 Writes to the C<.c> output file certain preprocessor directives and function
 436 headers needed in all such files.
 437
 438 =item * Arguments
 439
 440 None.
 441
 442 =item * Return Value
 443
 444 Returns true.
 445
 446 =back
 447
 448 =cut
 449
 450 sub standard_XS_defs {
 451   print <<"EOF";
 452 #ifndef PERL_UNUSED_VAR
 453 #  define PERL_UNUSED_VAR(var) if (0) var = var
 454 #endif
 455
 456 EOF
 457
 458   print <<"EOF";
 459 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
 460 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
 461
 462 /* prototype to pass -Wmissing-prototypes */
 463 STATIC void
 464 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
 465
 466 STATIC void
 467 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
 468 {
 469     const GV *const gv = CvGV(cv);
 470
 471     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 472
 473     if (gv) {
 474         const char *const gvname = GvNAME(gv);
 475         const HV *const stash = GvSTASH(gv);
 476         const char *const hvname = stash ? HvNAME(stash) : NULL;
 477
 478         if (hvname)
 479             Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
 480         else
 481             Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
 482     } else {
 483         /* Pants. I don't think that it should be possible to get here. */
 484         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
 485     }
 486 }
 487 #undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE
 488
 489 #ifdef PERL_IMPLICIT_CONTEXT
 490 #define croak_xs_usage(a,b)    S_croak_xs_usage(aTHX_ a,b)
 491 #else
 492 #define croak_xs_usage        S_croak_xs_usage
 493 #endif
 494
 495 #endif
 496
 497 /* NOTE: the prototype of newXSproto() is different in versions of perls,
 498  * so we define a portable version of newXSproto()
 499  */
 500 #ifdef newXS_flags
 501 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
 502 #else
 503 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
 504 #endif /* !defined(newXS_flags) */
 505
 506 EOF
 507   return 1;
 508 }
 509
 510 =head2 C<assign_func_args()>
 511
 512 =over 4
 513
 514 =item * Purpose
 515
 516 Perform assignment to the C<func_args> attribute.
 517
 518 =item * Arguments
 519
 520   $string = assign_func_args($self, $argsref, $class);
 521
 522 List of three elements.  Second is an array reference; third is a string.
 523
 524 =item * Return Value
 525
 526 String.
 527
 528 =back
 529
 530 =cut
 531
 532 sub assign_func_args {
 533   my ($self, $argsref, $class) = @_;
 534   my @func_args = @{$argsref};
 535   shift @func_args if defined($class);
 536
 537   for my $arg (@func_args) {
 538     $arg =~ s/^/&/ if $self->{in_out}->{$arg};
 539   }
 540   return join(", ", @func_args);
 541 }
 542
 543 =head2 C<analyze_preprocessor_statements()>
 544
 545 =over 4
 546
 547 =item * Purpose
 548
 549 Within each function inside each Xsub, print to the F<.c> output file certain
 550 preprocessor statements.
 551
 552 =item * Arguments
 553
 554       ( $self, $XSS_work_idx, $BootCode_ref ) =
 555         analyze_preprocessor_statements(
 556           $self, $statement, $XSS_work_idx, $BootCode_ref
 557         );
 558
 559 List of four elements.
 560
 561 =item * Return Value
 562
 563 Modifed values of three of the arguments passed to the function.  In
 564 particular, the C<XSStack> and C<InitFileCode> attributes are modified.
 565
 566 =back
 567
 568 =cut
 569
 570 sub analyze_preprocessor_statements {
 571   my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
 572
 573   if ($statement eq 'if') {
 574     $XSS_work_idx = @{ $self->{XSStack} };
 575     push(@{ $self->{XSStack} }, {type => 'if'});
 576   }
 577   else {
 578     $self->death("Error: `$statement' with no matching `if'")
 579       if $self->{XSStack}->[-1]{type} ne 'if';
 580     if ($self->{XSStack}->[-1]{varname}) {
 581       push(@{ $self->{InitFileCode} }, "#endif\n");
 582       push(@{ $BootCode_ref },     "#endif");
 583     }
 584
 585     my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
 586     if ($statement ne 'endif') {
 587       # Hide the functions defined in other #if branches, and reset.
 588       @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
 589       @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
 590     }
 591     else {
 592       my($tmp) = pop(@{ $self->{XSStack} });
 593       0 while (--$XSS_work_idx
 594            && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
 595       # Keep all new defined functions
 596       push(@fns, keys %{$tmp->{other_functions}});
 597       @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
 598     }
 599   }
 600   return ($self, $XSS_work_idx, $BootCode_ref);
 601 }
 602
 603 =head2 C<set_cond()>
 604
 605 =over 4
 606
 607 =item * Purpose
 608
 609 =item * Arguments
 610
 611 =item * Return Value
 612
 613 =back
 614
 615 =cut
 616
 617 sub set_cond {
 618   my ($ellipsis, $min_args, $num_args) = @_;
 619   my $cond;
 620   if ($ellipsis) {
 621     $cond = ($min_args ? qq(items < $min_args) : 0);
 622   }
 623   elsif ($min_args == $num_args) {
 624     $cond = qq(items != $min_args);
 625   }
 626   else {
 627     $cond = qq(items < $min_args || items > $num_args);
 628   }
 629   return $cond;
 630 }
 631
 632 =head2 C<current_line_number()>
 633
 634 =over 4
 635
 636 =item * Purpose
 637
 638 Figures out the current line number in the XS file.
 639
 640 =item * Arguments
 641
 642 C<$self>
 643
 644 =item * Return Value
 645
 646 The current line number.
 647
 648 =back
 649
 650 =cut
 651
 652 sub current_line_number {
 653   my $self = shift;
 654   my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
 655   return $line_number;
 656 }
 657
 658 =head2 C<Warn()>
 659
 660 =over 4
 661
 662 =item * Purpose
 663
 664 =item * Arguments
 665
 666 =item * Return Value
 667
 668 =back
 669
 670 =cut
 671
 672 sub Warn {
 673   my $self = shift;
 674   my $warn_line_number = $self->current_line_number();
 675   print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
 676 }
 677
 678 =head2 C<blurt()>
 679
 680 =over 4
 681
 682 =item * Purpose
 683
 684 =item * Arguments
 685
 686 =item * Return Value
 687
 688 =back
 689
 690 =cut
 691
 692 sub blurt {
 693   my $self = shift;
 694   $self->Warn(@_);
 695   $self->{errors}++
 696 }
 697
 698 =head2 C<death()>
 699
 700 =over 4
 701
 702 =item * Purpose
 703
 704 =item * Arguments
 705
 706 =item * Return Value
 707
 708 =back
 709
 710 =cut
 711
 712 sub death {
 713   my $self = shift;
 714   $self->Warn(@_);
 715   exit 1;
 716 }
 717
 718 =head2 C<check_conditional_preprocessor_statements()>
 719
 720 =over 4
 721
 722 =item * Purpose
 723
 724 =item * Arguments
 725
 726 =item * Return Value
 727
 728 =back
 729
 730 =cut
 731
 732 sub check_conditional_preprocessor_statements {
 733   my ($self) = @_;
 734   my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
 735   if (@cpp) {
 736     my $cpplevel;
 737     for my $cpp (@cpp) {
 738       if ($cpp =~ /^\#\s*if/) {
 739         $cpplevel++;
 740       }
 741       elsif (!$cpplevel) {
 742         $self->Warn("Warning: #else/elif/endif without #if in this function");
 743         print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
 744           if $self->{XSStack}->[-1]{type} eq 'if';
 745         return;
 746       }
 747       elsif ($cpp =~ /^\#\s*endif/) {
 748         $cpplevel--;
 749       }
 750     }
 751     $self->Warn("Warning: #if without #endif in this function") if $cpplevel;
 752   }
 753 }
 754
 755 1;
 756
 757 # vim: ts=2 sw=2 et: