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