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