utils/h2xs.PL

   1 #!/usr/local/bin/perl
   2
   3 use Config;
   4 use File::Basename qw(&basename &dirname);
   5
   6 # List explicitly here the variables you want Configure to
   7 # generate.  Metaconfig only looks for shell variables, so you
   8 # have to mention them as if they were shell variables, not
   9 # %Config entries.  Thus you write
  10 #  $startperl
  11 # to ensure Configure will look for $Config{startperl}.
  12
  13 # This forces PL files to create target in same directory as PL file.
  14 # This is so that make depend always knows where to find PL derivatives.
  15 chdir(dirname($0));
  16 ($file = basename($0)) =~ s/\.PL$//;
  17 $file =~ s/\.pl$//
  18         if ($^O eq 'VMS' or $^O eq 'os2');  # "case-forgiving"
  19
  20 open OUT,">$file" or die "Can't create $file: $!";
  21
  22 print "Extracting $file (with variable substitutions)\n";
  23
  24 # In this section, perl variables will be expanded during extraction.
  25 # You can use $Config{...} to use Configure variables.
  26
  27 print OUT <<"!GROK!THIS!";
  28 $Config{'startperl'}
  29     eval 'exec perl -S \$0 "\$@"'
  30         if 0;
  31 !GROK!THIS!
  32
  33 # In the following, perl variables are not expanded during extraction.
  34
  35 print OUT <<'!NO!SUBS!';
  36
  37 =head1 NAME
  38
  39 h2xs - convert .h C header files to Perl extensions
  40
  41 =head1 SYNOPSIS
  42
  43 B<h2xs> [B<-AOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile [extra_libraries]]
  44
  45 B<h2xs> B<-h>
  46
  47 =head1 DESCRIPTION
  48
  49 I<h2xs> builds a Perl extension from any C header file.  The extension will
  50 include functions which can be used to retrieve the value of any #define
  51 statement which was in the C header.
  52
  53 The I<module_name> will be used for the name of the extension.  If
  54 module_name is not supplied then the name of the header file will be used,
  55 with the first character capitalized.
  56
  57 If the extension might need extra libraries, they should be included
  58 here.  The extension Makefile.PL will take care of checking whether
  59 the libraries actually exist and how they should be loaded.
  60 The extra libraries should be specified in the form -lm -lposix, etc,
  61 just as on the cc command line.  By default, the Makefile.PL will
  62 search through the library path determined by Configure.  That path
  63 can be augmented by including arguments of the form B<-L/another/library/path>
  64 in the extra-libraries argument.
  65
  66 =head1 OPTIONS
  67
  68 =over 5
  69
  70 =item B<-A>
  71
  72 Omit all autoload facilities.  This is the same as B<-c> but also removes the
  73 S<C<require AutoLoader>> statement from the .pm file.
  74
  75 =item B<-F>
  76
  77 Additional flags to specify to C preprocessor when scanning header for
  78 function declarations. Should not be used without B<-x>.
  79
  80 =item B<-O>
  81
  82 Allows a pre-existing extension directory to be overwritten.
  83
  84 =item B<-P>
  85
  86 Omit the autogenerated stub POD section.
  87
  88 =item B<-X>
  89
  90 Omit the XS portion.  Used to generate templates for a module which is not
  91 XS-based.
  92
  93 =item B<-c>
  94
  95 Omit C<constant()> from the .xs file and corresponding specialised
  96 C<AUTOLOAD> from the .pm file.
  97
  98 =item B<-d>
  99
 100 Turn on debugging messages.
 101
 102 =item B<-f>
 103
 104 Allows an extension to be created for a header even if that header is
 105 not found in /usr/include.
 106
 107 =item B<-h>
 108
 109 Print the usage, help and version for this h2xs and exit.
 110
 111 =item B<-n> I<module_name>
 112
 113 Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
 114
 115 =item B<-p> I<prefix>
 116
 117 Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_>
 118 This sets up the XS B<PREFIX> keyword and removes the prefix from functions that are
 119 autoloaded via the C<constant()> mechansim.
 120
 121 =item B<-s> I<sub1,sub2>
 122
 123 Create a perl subroutine for the specified macros rather than autoload with the constant() subroutine.
 124 These macros are assumed to have a return type of B<char *>, e.g., S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
 125
 126 =item B<-v> I<version>
 127
 128 Specify a version number for this extension.  This version number is added
 129 to the templates.  The default is 0.01.
 130
 131 =item B<-x>
 132
 133 Automatically generate XSUBs basing on function declarations in the
 134 header file.  The package C<C::Scan> should be installed. If this
 135 option is specified, the name of the header file may look like
 136 C<NAME1,NAME2>. In this case NAME1 is used instead of the specified string,
 137 but XSUBs are emitted only for the declarations included from file NAME2.
 138
 139 Note that some types of arguments/return-values for functions may
 140 result in XSUB-declarations/typemap-entries which need
 141 hand-editing. Such may be objects which cannot be converted from/to a
 142 pointer (like C<long long>), pointers to functions, or arrays.
 143
 144 =back
 145
 146 =head1 EXAMPLES
 147
 148
 149         # Default behavior, extension is Rusers
 150         h2xs rpcsvc/rusers
 151
 152         # Same, but extension is RUSERS
 153         h2xs -n RUSERS rpcsvc/rusers
 154
 155         # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
 156         h2xs rpcsvc::rusers
 157
 158         # Extension is ONC::RPC.  Still finds <rpcsvc/rusers.h>
 159         h2xs -n ONC::RPC rpcsvc/rusers
 160
 161         # Without constant() or AUTOLOAD
 162         h2xs -c rpcsvc/rusers
 163
 164         # Creates templates for an extension named RPC
 165         h2xs -cfn RPC
 166
 167         # Extension is ONC::RPC.
 168         h2xs -cfn ONC::RPC
 169
 170         # Makefile.PL will look for library -lrpc in
 171         # additional directory /opt/net/lib
 172         h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
 173
 174         # Extension is DCE::rgynbase
 175         # prefix "sec_rgy_" is dropped from perl function names
 176         h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
 177
 178         # Extension is DCE::rgynbase
 179         # prefix "sec_rgy_" is dropped from perl function names
 180         # subroutines are created for sec_rgy_wildcard_name and sec_rgy_wildcard_sid
 181         h2xs -n DCE::rgynbase -p sec_rgy_ \
 182         -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
 183
 184         # Make XS without defines in perl.h, but with function declarations
 185         # visible from perl.h. Name of the extension is perl1.
 186         # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
 187         # Extra backslashes below because the string is passed to shell.
 188         # Note that a directory with perl header files would
 189         #  be added automatically to include path.
 190         h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
 191
 192         # Same with function declaration in proto.h as visible from perl.h.
 193         h2xs -xAn perl2 perl.h,proto.h
 194
 195 =head1 ENVIRONMENT
 196
 197 No environment variables are used.
 198
 199 =head1 AUTHOR
 200
 201 Larry Wall and others
 202
 203 =head1 SEE ALSO
 204
 205 L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
 206
 207 =head1 DIAGNOSTICS
 208
 209 The usual warnings if it cannot read or write the files involved.
 210
 211 =cut
 212
 213 my( $H2XS_VERSION ) = ' $Revision: 1.18 $ ' =~ /\$Revision:\s+([^\s]+)/;
 214 my $TEMPLATE_VERSION = '0.01';
 215
 216 use Getopt::Std;
 217
 218 sub usage{
 219         warn "@_\n" if @_;
 220     die "h2xs [-AOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]]
 221 version: $H2XS_VERSION
 222     -A   Omit all autoloading facilities (implies -c).
 223     -F   Additional flags for C preprocessor (used with -x).
 224     -O   Allow overwriting of a pre-existing extension directory.
 225     -P   Omit the stub POD section.
 226     -X   Omit the XS portion.
 227     -c   Omit the constant() function and specialised AUTOLOAD from the XS file.
 228     -d   Turn on debugging messages.
 229     -f   Force creation of the extension even if the C header does not exist.
 230     -h   Display this help message
 231     -n   Specify a name to use for the extension (recommended).
 232     -p   Specify a prefix which should be removed from the Perl function names.
 233     -s   Create subroutines for specified macros.
 234     -v   Specify a version number for this extension.
 235     -x   Autogenerate XSUBs using C::Scan.
 236 extra_libraries
 237          are any libraries that might be needed for loading the
 238          extension, e.g. -lm would try to link in the math library.
 239 ";
 240 }
 241
 242
 243 getopts("AF:OPXcdfhn:p:s:v:x") || usage;
 244
 245 usage if $opt_h;
 246
 247 if( $opt_v ){
 248         $TEMPLATE_VERSION = $opt_v;
 249 }
 250 $opt_c = 1 if $opt_A;
 251 %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
 252
 253 $path_h    = shift;
 254 $extralibs = "@ARGV";
 255
 256 usage "Must supply header file or module name\n"
 257         unless ($path_h or $opt_n);
 258
 259
 260 if( $path_h ){
 261     $name = $path_h;
 262     if( $path_h =~ s#::#/#g && $opt_n ){
 263         warn "Nesting of headerfile ignored with -n\n";
 264     }
 265     $path_h .= ".h" unless $path_h =~ /\.h$/;
 266     $fullpath = $path_h;
 267     $path_h =~ s/,.*$// if $opt_x;
 268     if ($^O eq 'VMS') {  # Consider overrides of default location
 269         if ($path_h !~ m![:>\[]!) {
 270             my($hadsys) = ($path_h =~ s!^sys/!!i);
 271             if ($ENV{'DECC$System_Include'})     { $path_h = "DECC\$System_Include:$path_h";    }
 272             elsif ($ENV{'DECC$Library_Include'}) { $path_h = "DECC\$Library_Include:$path_h";   }
 273             elsif ($ENV{'GNU_CC_Include'})       { $path_h = 'GNU_CC_Include:' .
 274                                                     ($hadsys ? '[vms]' : '[000000]') . $path_h; }
 275             elsif ($ENV{'VAXC$Include'})         { $path_h = "VAXC\$_Include:$path_h";          }
 276             else                                 { $path_h = "Sys\$Library:$path_h";            }
 277         }
 278     }
 279     elsif ($^O eq 'os2') {
 280         $path_h = "/usr/include/$path_h"
 281           if $path_h !~ m#^([a-z]:)?[./]#i and -r "/usr/include/$path_h";
 282     }
 283     else {
 284       $path_h = "/usr/include/$path_h"
 285         if $path_h !~ m#^[./]# and -r "/usr/include/$path_h";
 286     }
 287
 288     if (!$opt_c) {
 289       die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h );
 290       # Scan the header file (we should deal with nested header files)
 291       # Record the names of simple #define constants into const_names
 292       # Function prototypes are not (currently) processed.
 293       open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
 294       while (<CH>) {
 295         if (/^#[ \t]*define\s+([\$\w]+)\b\s*[^("]/) {
 296             print "Matched $_ ($1)\n" if $opt_d;
 297             $_ = $1;
 298             next if /^_.*_h_*$/i; # special case, but for what?
 299             if (defined $opt_p) {
 300               if (!/^$opt_p(\d)/) {
 301                 ++$prefix{$_} if s/^$opt_p//;
 302               }
 303               else {
 304                 warn "can't remove $opt_p prefix from '$_'!\n";
 305               }
 306             }
 307             $const_names{$_}++;
 308           }
 309       }
 310       close(CH);
 311       @const_names = sort keys %const_names;
 312     }
 313 }
 314
 315
 316 $module = $opt_n || do {
 317         $name =~ s/\.h$//;
 318         if( $name !~ /::/ ){
 319                 $name =~ s#^.*/##;
 320                 $name = "\u$name";
 321         }
 322         $name;
 323 };
 324
 325 (chdir 'ext', $ext = 'ext/') if -d 'ext';
 326
 327 if( $module =~ /::/ ){
 328         $nested = 1;
 329         @modparts = split(/::/,$module);
 330         $modfname = $modparts[-1];
 331         $modpname = join('/',@modparts);
 332 }
 333 else {
 334         $nested = 0;
 335         @modparts = ();
 336         $modfname = $modpname = $module;
 337 }
 338
 339
 340 if ($opt_O) {
 341         warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
 342 } else {
 343         die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
 344 }
 345 if( $nested ){
 346         $modpath = "";
 347         foreach (@modparts){
 348                 mkdir("$modpath$_", 0777);
 349                 $modpath .= "$_/";
 350         }
 351 }
 352 mkdir($modpname, 0777);
 353 chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
 354
 355 my %types_seen;
 356 my %std_types;
 357 my $fdecls;
 358 my $fdecls_parsed;
 359
 360 if( ! $opt_X ){  # use XS, unless it was disabled
 361   open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
 362   if ($opt_x) {
 363     require C::Scan;            # Run-time directive
 364     require Config;             # Run-time directive
 365     warn "Scanning typemaps...\n";
 366     get_typemap();
 367     my $c;
 368     my $filter;
 369     my $filename = $path_h;
 370     my $addflags = $opt_F || '';
 371     if ($fullpath =~ /,/) {
 372       $filename = $`;
 373       $filter = $';
 374     }
 375     warn "Scanning $filename for functions...\n";
 376     $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
 377     'add_cppflags' => $addflags;
 378     $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
 379
 380     $fdecls_parsed = $c->get('parsed_fdecls');
 381     $fdecls = $c->get('fdecls');
 382   }
 383 }
 384
 385 open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
 386
 387 $" = "\n\t";
 388 warn "Writing $ext$modpname/$modfname.pm\n";
 389
 390 print PM <<"END";
 391 package $module;
 392
 393 use strict;
 394 END
 395
 396 if( $opt_X || $opt_c || $opt_A ){
 397         # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD
 398         print PM <<'END';
 399 use vars qw($VERSION @ISA @EXPORT);
 400 END
 401 }
 402 else{
 403         # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
 404         # will want Carp.
 405         print PM <<'END';
 406 use Carp;
 407 use vars qw($VERSION @ISA @EXPORT $AUTOLOAD);
 408 END
 409 }
 410
 411 print PM <<'END';
 412
 413 require Exporter;
 414 END
 415
 416 print PM <<"END" if ! $opt_X;  # use DynaLoader, unless XS was disabled
 417 require DynaLoader;
 418 END
 419
 420 # require autoloader if XS is disabled.
 421 # if XS is enabled, require autoloader unless autoloading is disabled.
 422 if( $opt_X || (! $opt_A) ){
 423         print PM <<"END";
 424 require AutoLoader;
 425 END
 426 }
 427
 428 if( $opt_X || ($opt_c && ! $opt_A) ){
 429         # we won't have our own AUTOLOAD(), so we'll inherit it.
 430         if( ! $opt_X ) { # use DynaLoader, unless XS was disabled
 431                 print PM <<"END";
 432
 433 \@ISA = qw(Exporter AutoLoader DynaLoader);
 434 END
 435         }
 436         else{
 437                 print PM <<"END";
 438
 439 \@ISA = qw(Exporter AutoLoader);
 440 END
 441         }
 442 }
 443 else{
 444         # 1) we have our own AUTOLOAD(), so don't need to inherit it.
 445         # or
 446         # 2) we don't want autoloading mentioned.
 447         if( ! $opt_X ){ # use DynaLoader, unless XS was disabled
 448                 print PM <<"END";
 449
 450 \@ISA = qw(Exporter DynaLoader);
 451 END
 452         }
 453         else{
 454                 print PM <<"END";
 455
 456 \@ISA = qw(Exporter);
 457 END
 458         }
 459 }
 460
 461 print PM<<"END";
 462 # Items to export into callers namespace by default. Note: do not export
 463 # names by default without a very good reason. Use EXPORT_OK instead.
 464 # Do not simply export all your public functions/methods/constants.
 465 \@EXPORT = qw(
 466         @const_names
 467 );
 468 \$VERSION = '$TEMPLATE_VERSION';
 469
 470 END
 471
 472 print PM <<"END" unless $opt_c or $opt_X;
 473 sub AUTOLOAD {
 474     # This AUTOLOAD is used to 'autoload' constants from the constant()
 475     # XS function.  If a constant is not found then control is passed
 476     # to the AUTOLOAD in AutoLoader.
 477
 478     my \$constname;
 479     (\$constname = \$AUTOLOAD) =~ s/.*:://;
 480     my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
 481     if (\$! != 0) {
 482         if (\$! =~ /Invalid/) {
 483             \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
 484             goto &AutoLoader::AUTOLOAD;
 485         }
 486         else {
 487                 croak "Your vendor has not defined $module macro \$constname";
 488         }
 489     }
 490     eval "sub \$AUTOLOAD { \$val }";
 491     goto &\$AUTOLOAD;
 492 }
 493
 494 END
 495
 496 if( ! $opt_X ){ # print bootstrap, unless XS is disabled
 497         print PM <<"END";
 498 bootstrap $module \$VERSION;
 499 END
 500 }
 501
 502 if( $opt_P ){ # if POD is disabled
 503         $after = '__END__';
 504 }
 505 else {
 506         $after = '=cut';
 507 }
 508
 509 print PM <<"END";
 510
 511 # Preloaded methods go here.
 512
 513 # Autoload methods go after $after, and are processed by the autosplit program.
 514
 515 1;
 516 __END__
 517 END
 518
 519 $author = "A. U. Thor";
 520 $email = 'a.u.thor@a.galaxy.far.far.away';
 521
 522 my $const_doc = '';
 523 my $fdecl_doc = '';
 524 if (@const_names and not $opt_P) {
 525   $const_doc = <<EOD;
 526 \n=head1 Exported constants
 527
 528   @{[join "\n  ", @const_names]}
 529
 530 EOD
 531 }
 532 if (defined $fdecls and @$fdecls and not $opt_P) {
 533   $fdecl_doc = <<EOD;
 534 \n=head1 Exported functions
 535
 536   @{[join "\n  ", @$fdecls]}
 537
 538 EOD
 539 }
 540
 541 $pod = <<"END" unless $opt_P;
 542 ## Below is the stub of documentation for your module. You better edit it!
 543 #
 544 #=head1 NAME
 545 #
 546 #$module - Perl extension for blah blah blah
 547 #
 548 #=head1 SYNOPSIS
 549 #
 550 #  use $module;
 551 #  blah blah blah
 552 #
 553 #=head1 DESCRIPTION
 554 #
 555 #Stub documentation for $module was created by h2xs. It looks like the
 556 #author of the extension was negligent enough to leave the stub
 557 #unedited.
 558 #
 559 #Blah blah blah.
 560 #$const_doc$fdecl_doc
 561 #=head1 AUTHOR
 562 #
 563 #$author, $email
 564 #
 565 #=head1 SEE ALSO
 566 #
 567 #perl(1).
 568 #
 569 #=cut
 570 END
 571
 572 $pod =~ s/^\#//gm unless $opt_P;
 573 print PM $pod unless $opt_P;
 574
 575 close PM;
 576
 577
 578 if( ! $opt_X ){ # print XS, unless it is disabled
 579 warn "Writing $ext$modpname/$modfname.xs\n";
 580
 581 print XS <<"END";
 582 #ifdef __cplusplus
 583 extern "C" {
 584 #endif
 585 #include "EXTERN.h"
 586 #include "perl.h"
 587 #include "XSUB.h"
 588 #ifdef __cplusplus
 589 }
 590 #endif
 591
 592 END
 593 if( $path_h ){
 594         my($h) = $path_h;
 595         $h =~ s#^/usr/include/##;
 596         if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
 597 print XS <<"END";
 598 #include <$h>
 599
 600 END
 601 }
 602
 603 if( ! $opt_c ){
 604 print XS <<"END";
 605 static int
 606 not_here(s)
 607 char *s;
 608 {
 609     croak("$module::%s not implemented on this architecture", s);
 610     return -1;
 611 }
 612
 613 static double
 614 constant(name, arg)
 615 char *name;
 616 int arg;
 617 {
 618     errno = 0;
 619     switch (*name) {
 620 END
 621
 622 my(@AZ, @az, @under);
 623
 624 foreach(@const_names){
 625     @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/;
 626     @az = 'a' .. 'z' if !@az && /^[a-z]/;
 627     @under = '_'  if !@under && /^_/;
 628 }
 629
 630 foreach $letter (@AZ, @az, @under) {
 631
 632     last if $letter eq 'a' && !@const_names;
 633
 634     print XS "    case '$letter':\n";
 635     my($name);
 636     while (substr($const_names[0],0,1) eq $letter) {
 637         $name = shift(@const_names);
 638         $macro = $prefix{$name} ? "$opt_p$name" : $name;
 639         next if $const_xsub{$macro};
 640         print XS <<"END";
 641         if (strEQ(name, "$name"))
 642 #ifdef $macro
 643             return $macro;
 644 #else
 645             goto not_there;
 646 #endif
 647 END
 648     }
 649     print XS <<"END";
 650         break;
 651 END
 652 }
 653 print XS <<"END";
 654     }
 655     errno = EINVAL;
 656     return 0;
 657
 658 not_there:
 659     errno = ENOENT;
 660     return 0;
 661 }
 662
 663 END
 664 }
 665
 666 $prefix = "PREFIX = $opt_p" if defined $opt_p;
 667 # Now switch from C to XS by issuing the first MODULE declaration:
 668 print XS <<"END";
 669
 670 MODULE = $module                PACKAGE = $module               $prefix
 671
 672 END
 673
 674 foreach (sort keys %const_xsub) {
 675     print XS <<"END";
 676 char *
 677 $_()
 678
 679     CODE:
 680 #ifdef $_
 681     RETVAL = $_;
 682 #else
 683     croak("Your vendor has not defined the $module macro $_");
 684 #endif
 685
 686     OUTPUT:
 687     RETVAL
 688
 689 END
 690 }
 691
 692 # If a constant() function was written then output a corresponding
 693 # XS declaration:
 694 print XS <<"END" unless $opt_c;
 695
 696 double
 697 constant(name,arg)
 698         char *          name
 699         int             arg
 700
 701 END
 702
 703 my %seen_decl;
 704
 705
 706 sub print_decl {
 707   my $fh = shift;
 708   my $decl = shift;
 709   my ($type, $name, $args) = @$decl;
 710   return if $seen_decl{$name}++; # Need to do the same for docs as well?
 711
 712   my @argnames = map {$_->[1]} @$args;
 713   my @argtypes = map { normalize_type( $_->[0] ) } @$args;
 714   my @argarrays = map { $_->[4] || '' } @$args;
 715   my $numargs = @$args;
 716   if ($numargs and $argtypes[-1] eq '...') {
 717     $numargs--;
 718     $argnames[-1] = '...';
 719   }
 720   local $" = ', ';
 721   $type = normalize_type($type);
 722
 723   print $fh <<"EOP";
 724
 725 $type
 726 $name(@argnames)
 727 EOP
 728
 729   for $arg (0 .. $numargs - 1) {
 730     print $fh <<"EOP";
 731         $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
 732 EOP
 733   }
 734 }
 735
 736 # Should be called before any actual call to normalize_type().
 737 sub get_typemap {
 738   # We do not want to read ./typemap by obvios reasons.
 739   my @tm =  qw(../../../typemap ../../typemap ../typemap);
 740   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
 741   unshift @tm, $stdtypemap;
 742   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
 743   my $image;
 744
 745   foreach $typemap (@tm) {
 746     next unless -e $typemap ;
 747     # skip directories, binary files etc.
 748     warn " Scanning $typemap\n";
 749     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
 750       unless -T $typemap ;
 751     open(TYPEMAP, $typemap)
 752       or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
 753     my $mode = 'Typemap';
 754     while (<TYPEMAP>) {
 755       next if /^\s*\#/;
 756       if (/^INPUT\s*$/)   { $mode = 'Input'; next; }
 757       elsif (/^OUTPUT\s*$/)  { $mode = 'Output'; next; }
 758       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
 759       elsif ($mode eq 'Typemap') {
 760         next if /^\s*($|\#)/ ;
 761         if ( ($type, $image) =
 762              /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
 763              # This may reference undefined functions:
 764              and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
 765           normalize_type($type);
 766         }
 767       }
 768     }
 769     close(TYPEMAP) or die "Cannot close $typemap: $!";
 770   }
 771   %std_types = %types_seen;
 772   %types_seen = ();
 773 }
 774
 775
 776 sub normalize_type {
 777   my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*';
 778   my $type = shift;
 779   $type =~ s/$ignore_mods//go;
 780   $type =~ s/([\]\[()])/ \1 /g;
 781   $type =~ s/\s+/ /g;
 782   $type =~ s/\s+$//;
 783   $type =~ s/^\s+//;
 784   $type =~ s/\b\*/ */g;
 785   $type =~ s/\*\b/* /g;
 786   $type =~ s/\*\s+(?=\*)/*/g;
 787   $types_seen{$type}++
 788     unless $type eq '...' or $type eq 'void' or $std_types{$type};
 789   $type;
 790 }
 791
 792 if ($opt_x) {
 793     for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
 794 }
 795
 796 close XS;
 797
 798 if (%types_seen) {
 799   my $type;
 800   warn "Writing $ext$modpname/typemap\n";
 801   open TM, ">typemap" or die "Cannot open typemap file for write: $!";
 802
 803   for $type (keys %types_seen) {
 804     print TM $type, "\t" x (6 - int((length $type)/8)), "T_PTROBJ\n"
 805   }
 806
 807   close TM or die "Cannot close typemap file for write: $!";
 808 }
 809
 810 } # if( ! $opt_X )
 811
 812 warn "Writing $ext$modpname/Makefile.PL\n";
 813 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
 814
 815 print PL <<'END';
 816 use ExtUtils::MakeMaker;
 817 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
 818 # the contents of the Makefile that is written.
 819 END
 820 print PL "WriteMakefile(\n";
 821 print PL "    'NAME'    => '$module',\n";
 822 print PL "    'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n";
 823 if( ! $opt_X ){ # print C stuff, unless XS is disabled
 824   print PL "    'LIBS'  => ['$extralibs'],   # e.g., '-lm' \n";
 825   print PL "    'DEFINE'        => '',     # e.g., '-DHAVE_SOMETHING' \n";
 826   print PL "    'INC'   => '',     # e.g., '-I/usr/include/other' \n";
 827 }
 828 print PL ");\n";
 829 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
 830
 831 warn "Writing $ext$modpname/test.pl\n";
 832 open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
 833 print EX <<'_END_';
 834 # Before `make install' is performed this script should be runnable with
 835 # `make test'. After `make install' it should work as `perl test.pl'
 836
 837 ######################### We start with some black magic to print on failure.
 838
 839 # Change 1..1 below to 1..last_test_to_print .
 840 # (It may become useful if the test is moved to ./t subdirectory.)
 841
 842 BEGIN { $| = 1; print "1..1\n"; }
 843 END {print "not ok 1\n" unless $loaded;}
 844 _END_
 845 print EX <<_END_;
 846 use $module;
 847 _END_
 848 print EX <<'_END_';
 849 $loaded = 1;
 850 print "ok 1\n";
 851
 852 ######################### End of black magic.
 853
 854 # Insert your test code below (better if it prints "ok 13"
 855 # (correspondingly "not ok 13") depending on the success of chunk 13
 856 # of the test code):
 857
 858 _END_
 859 close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
 860
 861 warn "Writing $ext$modpname/Changes\n";
 862 open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
 863 print EX "Revision history for Perl extension $module.\n\n";
 864 print EX "$TEMPLATE_VERSION  ",scalar localtime,"\n";
 865 print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n";
 866 close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
 867
 868 warn "Writing $ext$modpname/MANIFEST\n";
 869 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
 870 @files = <*>;
 871 if (!@files) {
 872   eval {opendir(D,'.');};
 873   unless ($@) { @files = readdir(D); closedir(D); }
 874 }
 875 if (!@files) { @files = map {chomp && $_} `ls`; }
 876 print MANI join("\n",@files);
 877 close MANI;
 878 !NO!SUBS!
 879
 880 close OUT or die "Can't close $file: $!";
 881 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 882 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';