utils/h2xs.PL

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