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   make_targetable
  20   map_type
  21   standard_XS_defs
  22   assign_func_args
  23   analyze_preprocessor_statements
  24   set_cond
  25   Warn
  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   my $typemap = ExtUtils::Typemaps->new;
 307   foreach my $typemap_loc (@tm) {
 308     next unless -f $typemap_loc;
 309     # skip directories, binary files etc.
 310     warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"), next
 311       unless -T $typemap_loc;
 312
 313     $typemap->merge(file => $typemap_loc, replace => 1);
 314   }
 315
 316   return $typemap;
 317 }
 318
 319 =head2 C<make_targetable()>
 320
 321 =over 4
 322
 323 =item * Purpose
 324
 325 Populate C<%targetable>.  This constitutes a refinement of the output of
 326 C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>.
 327
 328 =item * Arguments
 329
 330   %targetable = make_targetable($output_expr_ref);
 331
 332 Single hash reference:  the fourth such ref returned by C<process_typemaps()>.
 333
 334 =item * Return Value
 335
 336 Hash.
 337
 338 =back
 339
 340 =cut
 341
 342 sub make_targetable {
 343   my $output_expr_ref = shift;
 344
 345   our $bal; # ()-balanced
 346   $bal = qr[
 347     (?:
 348       (?>[^()]+)
 349       |
 350       \( (??{ $bal }) \)
 351     )*
 352   ]x;
 353
 354   # matches variations on (SV*)
 355   my $sv_cast = qr[
 356     (?:
 357       \( \s* SV \s* \* \s* \) \s*
 358     )?
 359   ]x;
 360
 361   my $size = qr[ # Third arg (to setpvn)
 362     , \s* (??{ $bal })
 363   ]x;
 364
 365   my %targetable;
 366   foreach my $key (keys %{ $output_expr_ref }) {
 367     # We can still bootstrap compile 're', because in code re.pm is
 368     # available to miniperl, and does not attempt to load the XS code.
 369     use re 'eval';
 370
 371     my ($type, $with_size, $arg, $sarg) =
 372       ($output_expr_ref->{$key} =~
 373         m[^
 374           \s+
 375           sv_set([iunp])v(n)?    # Type, is_setpvn
 376           \s*
 377           \( \s*
 378             $sv_cast \$arg \s* , \s*
 379             ( (??{ $bal }) )    # Set from
 380           ( (??{ $size }) )?    # Possible sizeof set-from
 381           \) \s* ; \s* $
 382         ]x
 383     );
 384     $targetable{$key} = [$type, $with_size, $arg, $sarg] if $type;
 385   }
 386   return %targetable;
 387 }
 388
 389 =head2 C<map_type()>
 390
 391 =over 4
 392
 393 =item * Purpose
 394
 395 Performs a mapping at several places inside C<PARAGRAPH> loop.
 396
 397 =item * Arguments
 398
 399   $type = map_type($self, $type, $varname);
 400
 401 List of three arguments.
 402
 403 =item * Return Value
 404
 405 String holding augmented version of second argument.
 406
 407 =back
 408
 409 =cut
 410
 411 sub map_type {
 412   my ($self, $type, $varname) = @_;
 413
 414   # C++ has :: in types too so skip this
 415   $type =~ tr/:/_/ unless $self->{hiertype};
 416   $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
 417   if ($varname) {
 418     if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
 419       (substr $type, pos $type, 0) = " $varname ";
 420     }
 421     else {
 422       $type .= "\t$varname";
 423     }
 424   }
 425   return $type;
 426 }
 427
 428 =head2 C<standard_XS_defs()>
 429
 430 =over 4
 431
 432 =item * Purpose
 433
 434 Writes to the C<.c> output file certain preprocessor directives and function
 435 headers needed in all such files.
 436
 437 =item * Arguments
 438
 439 None.
 440
 441 =item * Return Value
 442
 443 Returns true.
 444
 445 =back
 446
 447 =cut
 448
 449 sub standard_XS_defs {
 450   print <<"EOF";
 451 #ifndef PERL_UNUSED_VAR
 452 #  define PERL_UNUSED_VAR(var) if (0) var = var
 453 #endif
 454
 455 EOF
 456
 457   print <<"EOF";
 458 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
 459 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
 460
 461 /* prototype to pass -Wmissing-prototypes */
 462 STATIC void
 463 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
 464
 465 STATIC void
 466 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
 467 {
 468     const GV *const gv = CvGV(cv);
 469
 470     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 471
 472     if (gv) {
 473         const char *const gvname = GvNAME(gv);
 474         const HV *const stash = GvSTASH(gv);
 475         const char *const hvname = stash ? HvNAME(stash) : NULL;
 476
 477         if (hvname)
 478             Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
 479         else
 480             Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
 481     } else {
 482         /* Pants. I don't think that it should be possible to get here. */
 483         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
 484     }
 485 }
 486 #undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE
 487
 488 #ifdef PERL_IMPLICIT_CONTEXT
 489 #define croak_xs_usage(a,b)    S_croak_xs_usage(aTHX_ a,b)
 490 #else
 491 #define croak_xs_usage        S_croak_xs_usage
 492 #endif
 493
 494 #endif
 495
 496 /* NOTE: the prototype of newXSproto() is different in versions of perls,
 497  * so we define a portable version of newXSproto()
 498  */
 499 #ifdef newXS_flags
 500 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
 501 #else
 502 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
 503 #endif /* !defined(newXS_flags) */
 504
 505 EOF
 506   return 1;
 507 }
 508
 509 =head2 C<assign_func_args()>
 510
 511 =over 4
 512
 513 =item * Purpose
 514
 515 Perform assignment to the C<func_args> attribute.
 516
 517 =item * Arguments
 518
 519   $string = assign_func_args($self, $argsref, $class);
 520
 521 List of three elements.  Second is an array reference; third is a string.
 522
 523 =item * Return Value
 524
 525 String.
 526
 527 =back
 528
 529 =cut
 530
 531 sub assign_func_args {
 532   my ($self, $argsref, $class) = @_;
 533   my @func_args = @{$argsref};
 534   shift @func_args if defined($class);
 535
 536   for my $arg (@func_args) {
 537     $arg =~ s/^/&/ if $self->{in_out}->{$arg};
 538   }
 539   return join(", ", @func_args);
 540 }
 541
 542 =head2 C<analyze_preprocessor_statements()>
 543
 544 =over 4
 545
 546 =item * Purpose
 547
 548 Within each function inside each Xsub, print to the F<.c> output file certain
 549 preprocessor statements.
 550
 551 =item * Arguments
 552
 553       ( $self, $XSS_work_idx, $BootCode_ref ) =
 554         analyze_preprocessor_statements(
 555           $self, $statement, $XSS_work_idx, $BootCode_ref
 556         );
 557
 558 List of four elements.
 559
 560 =item * Return Value
 561
 562 Modifed values of three of the arguments passed to the function.  In
 563 particular, the C<XSStack> and C<InitFileCode> attributes are modified.
 564
 565 =back
 566
 567 =cut
 568
 569 sub analyze_preprocessor_statements {
 570   my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
 571
 572   if ($statement eq 'if') {
 573     $XSS_work_idx = @{ $self->{XSStack} };
 574     push(@{ $self->{XSStack} }, {type => 'if'});
 575   }
 576   else {
 577     death ("Error: `$statement' with no matching `if'")
 578       if $self->{XSStack}->[-1]{type} ne 'if';
 579     if ($self->{XSStack}->[-1]{varname}) {
 580       push(@{ $self->{InitFileCode} }, "#endif\n");
 581       push(@{ $BootCode_ref },     "#endif");
 582     }
 583
 584     my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
 585     if ($statement ne 'endif') {
 586       # Hide the functions defined in other #if branches, and reset.
 587       @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
 588       @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
 589     }
 590     else {
 591       my($tmp) = pop(@{ $self->{XSStack} });
 592       0 while (--$XSS_work_idx
 593            && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
 594       # Keep all new defined functions
 595       push(@fns, keys %{$tmp->{other_functions}});
 596       @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
 597     }
 598   }
 599   return ($self, $XSS_work_idx, $BootCode_ref);
 600 }
 601
 602 =head2 C<set_cond()>
 603
 604 =over 4
 605
 606 =item * Purpose
 607
 608 =item * Arguments
 609
 610 =item * Return Value
 611
 612 =back
 613
 614 =cut
 615
 616 sub set_cond {
 617   my ($ellipsis, $min_args, $num_args) = @_;
 618   my $cond;
 619   if ($ellipsis) {
 620     $cond = ($min_args ? qq(items < $min_args) : 0);
 621   }
 622   elsif ($min_args == $num_args) {
 623     $cond = qq(items != $min_args);
 624   }
 625   else {
 626     $cond = qq(items < $min_args || items > $num_args);
 627   }
 628   return $cond;
 629 }
 630
 631 =head2 C<Warn()>
 632
 633 =over 4
 634
 635 =item * Purpose
 636
 637 =item * Arguments
 638
 639 =item * Return Value
 640
 641 =back
 642
 643 =cut
 644
 645 sub Warn {
 646   my $self = shift;
 647   # work out the line number
 648   my $warn_line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
 649
 650   print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
 651 }
 652
 653 =head2 C<blurt()>
 654
 655 =over 4
 656
 657 =item * Purpose
 658
 659 =item * Arguments
 660
 661 =item * Return Value
 662
 663 =back
 664
 665 =cut
 666
 667 sub blurt {
 668   my $self = shift;
 669   Warn($self, @_);
 670   $self->{errors}++
 671 }
 672
 673 =head2 C<death()>
 674
 675 =over 4
 676
 677 =item * Purpose
 678
 679 =item * Arguments
 680
 681 =item * Return Value
 682
 683 =back
 684
 685 =cut
 686
 687 sub death {
 688   my $self = shift;
 689   Warn($self, @_);
 690   exit 1;
 691 }
 692
 693 =head2 C<check_conditional_preprocessor_statements()>
 694
 695 =over 4
 696
 697 =item * Purpose
 698
 699 =item * Arguments
 700
 701 =item * Return Value
 702
 703 =back
 704
 705 =cut
 706
 707 sub check_conditional_preprocessor_statements {
 708   my ($self) = @_;
 709   my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
 710   if (@cpp) {
 711     my $cpplevel;
 712     for my $cpp (@cpp) {
 713       if ($cpp =~ /^\#\s*if/) {
 714         $cpplevel++;
 715       }
 716       elsif (!$cpplevel) {
 717         Warn( $self, "Warning: #else/elif/endif without #if in this function");
 718         print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
 719           if $self->{XSStack}->[-1]{type} eq 'if';
 720         return;
 721       }
 722       elsif ($cpp =~ /^\#\s*endif/) {
 723         $cpplevel--;
 724       }
 725     }
 726     Warn( $self, "Warning: #if without #endif in this function") if $cpplevel;
 727   }
 728 }
 729
 730 1;
 731
 732 # vim: ts=2 sw=2 et: