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<make_targetable()>
 397
 398 =over 4
 399
 400 =item * Purpose
 401
 402 Populate C<%targetable>.  This constitutes a refinement of the output of
 403 C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>.
 404
 405 =item * Arguments
 406
 407   %targetable = make_targetable($output_expr_ref);
 408
 409 Single hash reference:  the fourth such ref returned by C<process_typemaps()>.
 410
 411 =item * Return Value
 412
 413 Hash.
 414
 415 =back
 416
 417 =cut
 418
 419 sub make_targetable {
 420   my $output_expr_ref = shift;
 421
 422   our $bal; # ()-balanced
 423   $bal = qr[
 424     (?:
 425       (?>[^()]+)
 426       |
 427       \( (??{ $bal }) \)
 428     )*
 429   ]x;
 430
 431   # matches variations on (SV*)
 432   my $sv_cast = qr[
 433     (?:
 434       \( \s* SV \s* \* \s* \) \s*
 435     )?
 436   ]x;
 437
 438   my $size = qr[ # Third arg (to setpvn)
 439     , \s* (??{ $bal })
 440   ]x;
 441
 442   my %targetable;
 443   foreach my $key (keys %{ $output_expr_ref }) {
 444     # We can still bootstrap compile 're', because in code re.pm is
 445     # available to miniperl, and does not attempt to load the XS code.
 446     use re 'eval';
 447
 448     my ($type, $with_size, $arg, $sarg) =
 449       ($output_expr_ref->{$key} =~
 450         m[^
 451           \s+
 452           sv_set([iunp])v(n)?    # Type, is_setpvn
 453           \s*
 454           \( \s*
 455             $sv_cast \$arg \s* , \s*
 456             ( (??{ $bal }) )    # Set from
 457           ( (??{ $size }) )?    # Possible sizeof set-from
 458           \) \s* ; \s* $
 459         ]x
 460     );
 461     $targetable{$key} = [$type, $with_size, $arg, $sarg] if $type;
 462   }
 463   return %targetable;
 464 }
 465
 466 =head2 C<map_type()>
 467
 468 =over 4
 469
 470 =item * Purpose
 471
 472 Performs a mapping at several places inside C<PARAGRAPH> loop.
 473
 474 =item * Arguments
 475
 476   $type = map_type($self, $type, $varname);
 477
 478 List of three arguments.
 479
 480 =item * Return Value
 481
 482 String holding augmented version of second argument.
 483
 484 =back
 485
 486 =cut
 487
 488 sub map_type {
 489   my ($self, $type, $varname) = @_;
 490
 491   # C++ has :: in types too so skip this
 492   $type =~ tr/:/_/ unless $self->{hiertype};
 493   $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
 494   if ($varname) {
 495     if ($type =~ / \( \s* \* (?= \s* \) ) /xg) {
 496       (substr $type, pos $type, 0) = " $varname ";
 497     }
 498     else {
 499       $type .= "\t$varname";
 500     }
 501   }
 502   return $type;
 503 }
 504
 505 =head2 C<standard_XS_defs()>
 506
 507 =over 4
 508
 509 =item * Purpose
 510
 511 Writes to the C<.c> output file certain preprocessor directives and function
 512 headers needed in all such files.
 513
 514 =item * Arguments
 515
 516 None.
 517
 518 =item * Return Value
 519
 520 Implicitly returns true when final C<print> statement completes.
 521
 522 =back
 523
 524 =cut
 525
 526 sub standard_XS_defs {
 527   print <<"EOF";
 528 #ifndef PERL_UNUSED_VAR
 529 #  define PERL_UNUSED_VAR(var) if (0) var = var
 530 #endif
 531
 532 EOF
 533
 534   print <<"EOF";
 535 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
 536 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
 537
 538 /* prototype to pass -Wmissing-prototypes */
 539 STATIC void
 540 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
 541
 542 STATIC void
 543 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
 544 {
 545     const GV *const gv = CvGV(cv);
 546
 547     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 548
 549     if (gv) {
 550         const char *const gvname = GvNAME(gv);
 551         const HV *const stash = GvSTASH(gv);
 552         const char *const hvname = stash ? HvNAME(stash) : NULL;
 553
 554         if (hvname)
 555             Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
 556         else
 557             Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
 558     } else {
 559         /* Pants. I don't think that it should be possible to get here. */
 560         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
 561     }
 562 }
 563 #undef  PERL_ARGS_ASSERT_CROAK_XS_USAGE
 564
 565 #ifdef PERL_IMPLICIT_CONTEXT
 566 #define croak_xs_usage(a,b)    S_croak_xs_usage(aTHX_ a,b)
 567 #else
 568 #define croak_xs_usage        S_croak_xs_usage
 569 #endif
 570
 571 #endif
 572
 573 /* NOTE: the prototype of newXSproto() is different in versions of perls,
 574  * so we define a portable version of newXSproto()
 575  */
 576 #ifdef newXS_flags
 577 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
 578 #else
 579 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
 580 #endif /* !defined(newXS_flags) */
 581
 582 EOF
 583 }
 584
 585 =head2 C<assign_func_args()>
 586
 587 =over 4
 588
 589 =item * Purpose
 590
 591 Perform assignment to the C<func_args> attribute.
 592
 593 =item * Arguments
 594
 595   $string = assign_func_args($self, $argsref, $class);
 596
 597 List of three elements.  Second is an array reference; third is a string.
 598
 599 =item * Return Value
 600
 601 String.
 602
 603 =back
 604
 605 =cut
 606
 607 sub assign_func_args {
 608   my ($self, $argsref, $class) = @_;
 609   my @func_args = @{$argsref};
 610   shift @func_args if defined($class);
 611
 612   for my $arg (@func_args) {
 613     $arg =~ s/^/&/ if $self->{in_out}->{$arg};
 614   }
 615   return join(", ", @func_args);
 616 }
 617
 618 =head2 C<analyze_preprocessor_statements()>
 619
 620 =over 4
 621
 622 =item * Purpose
 623
 624 Within each function inside each Xsub, print to the F<.c> output file certain
 625 preprocessor statements.
 626
 627 =item * Arguments
 628
 629       ( $self, $XSS_work_idx, $BootCode_ref ) =
 630         analyze_preprocessor_statements(
 631           $self, $statement, $XSS_work_idx, $BootCode_ref
 632         );
 633
 634 List of four elements.
 635
 636 =item * Return Value
 637
 638 Modifed values of three of the arguments passed to the function.  In
 639 particular, the C<XSStack> and C<InitFileCode> attributes are modified.
 640
 641 =back
 642
 643 =cut
 644
 645 sub analyze_preprocessor_statements {
 646   my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_;
 647
 648   if ($statement eq 'if') {
 649     $XSS_work_idx = @{ $self->{XSStack} };
 650     push(@{ $self->{XSStack} }, {type => 'if'});
 651   }
 652   else {
 653     death ("Error: `$statement' with no matching `if'")
 654       if $self->{XSStack}->[-1]{type} ne 'if';
 655     if ($self->{XSStack}->[-1]{varname}) {
 656       push(@{ $self->{InitFileCode} }, "#endif\n");
 657       push(@{ $BootCode_ref },     "#endif");
 658     }
 659
 660     my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
 661     if ($statement ne 'endif') {
 662       # Hide the functions defined in other #if branches, and reset.
 663       @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
 664       @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
 665     }
 666     else {
 667       my($tmp) = pop(@{ $self->{XSStack} });
 668       0 while (--$XSS_work_idx
 669            && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
 670       # Keep all new defined functions
 671       push(@fns, keys %{$tmp->{other_functions}});
 672       @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
 673     }
 674   }
 675   return ($self, $XSS_work_idx, $BootCode_ref);
 676 }
 677
 678 =head2 C<set_cond()>
 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 set_cond {
 693   my ($ellipsis, $min_args, $num_args) = @_;
 694   my $cond;
 695   if ($ellipsis) {
 696     $cond = ($min_args ? qq(items < $min_args) : 0);
 697   }
 698   elsif ($min_args == $num_args) {
 699     $cond = qq(items != $min_args);
 700   }
 701   else {
 702     $cond = qq(items < $min_args || items > $num_args);
 703   }
 704   return $cond;
 705 }
 706
 707 =head2 C<Warn()>
 708
 709 =over 4
 710
 711 =item * Purpose
 712
 713 =item * Arguments
 714
 715 =item * Return Value
 716
 717 =back
 718
 719 =cut
 720
 721 sub Warn {
 722   my $self = shift;
 723   # work out the line number
 724   my $warn_line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
 725
 726   print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
 727 }
 728
 729 =head2 C<blurt()>
 730
 731 =over 4
 732
 733 =item * Purpose
 734
 735 =item * Arguments
 736
 737 =item * Return Value
 738
 739 =back
 740
 741 =cut
 742
 743 sub blurt {
 744   my $self = shift;
 745   Warn($self, @_);
 746   $self->{errors}++
 747 }
 748
 749 =head2 C<death()>
 750
 751 =over 4
 752
 753 =item * Purpose
 754
 755 =item * Arguments
 756
 757 =item * Return Value
 758
 759 =back
 760
 761 =cut
 762
 763 sub death {
 764   my $self = shift;
 765   Warn($self, @_);
 766   exit 1;
 767 }
 768
 769 =head2 C<check_conditional_preprocessor_statements()>
 770
 771 =over 4
 772
 773 =item * Purpose
 774
 775 =item * Arguments
 776
 777 =item * Return Value
 778
 779 =back
 780
 781 =cut
 782
 783 sub check_conditional_preprocessor_statements {
 784   my ($self) = @_;
 785   my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
 786   if (@cpp) {
 787     my $cpplevel;
 788     for my $cpp (@cpp) {
 789       if ($cpp =~ /^\#\s*if/) {
 790         $cpplevel++;
 791       }
 792       elsif (!$cpplevel) {
 793         Warn( $self, "Warning: #else/elif/endif without #if in this function");
 794         print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
 795           if $self->{XSStack}->[-1]{type} eq 'if';
 796         return;
 797       }
 798       elsif ($cpp =~ /^\#\s*endif/) {
 799         $cpplevel--;
 800       }
 801     }
 802     Warn( $self, "Warning: #if without #endif in this function") if $cpplevel;
 803   }
 804 }
 805
 806 1;
 807
 808 # vim: ts=2 sw=2 et: