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         my @fdecls;
 378         foreach my $filename (@path_h) {
 379     my $addflags = $opt_F || '';
 380     if ($fullpath =~ /,/) {
 381       $filename = $`;
 382       $filter = $';
 383     }
 384     warn "Scanning $filename for functions...\n";
 385     $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
 386     'add_cppflags' => $addflags;
 387     $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
 388
 389     $fdecls_parsed = $c->get('parsed_fdecls');
 390             push(@fdecls, @{$c->get('fdecls')});
 391         }
 392         $fdecls = [ @fdecls ];
 393   }
 394 }
 395
 396 open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
 397
 398 $" = "\n\t";
 399 warn "Writing $ext$modpname/$modfname.pm\n";
 400
 401 print PM <<"END";
 402 package $module;
 403
 404 use strict;
 405 END
 406
 407 if( $opt_X || $opt_c || $opt_A ){
 408         # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD
 409         print PM <<'END';
 410 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
 411 END
 412 }
 413 else{
 414         # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
 415         # will want Carp.
 416         print PM <<'END';
 417 use Carp;
 418 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
 419 END
 420 }
 421
 422 print PM <<'END';
 423
 424 require Exporter;
 425 END
 426
 427 print PM <<"END" if ! $opt_X;  # use DynaLoader, unless XS was disabled
 428 require DynaLoader;
 429 END
 430
 431 # require autoloader if XS is disabled.
 432 # if XS is enabled, require autoloader unless autoloading is disabled.
 433 if( ($opt_X && (! $opt_A)) || (!$opt_X) ) {
 434         print PM <<"END";
 435 require AutoLoader;
 436 END
 437 }
 438
 439 if( $opt_X || ($opt_c && ! $opt_A) ){
 440         # we won't have our own AUTOLOAD(), so we'll inherit it.
 441         if( ! $opt_X ) { # use DynaLoader, unless XS was disabled
 442                 print PM <<"END";
 443
 444 \@ISA = qw(Exporter AutoLoader DynaLoader);
 445 END
 446         }
 447         else{
 448                 print PM <<"END";
 449
 450 \@ISA = qw(Exporter AutoLoader);
 451 END
 452         }
 453 }
 454 else{
 455         # 1) we have our own AUTOLOAD(), so don't need to inherit it.
 456         # or
 457         # 2) we don't want autoloading mentioned.
 458         if( ! $opt_X ){ # use DynaLoader, unless XS was disabled
 459                 print PM <<"END";
 460
 461 \@ISA = qw(Exporter DynaLoader);
 462 END
 463         }
 464         else{
 465                 print PM <<"END";
 466
 467 \@ISA = qw(Exporter);
 468 END
 469         }
 470 }
 471
 472 print PM<<"END";
 473 # Items to export into callers namespace by default. Note: do not export
 474 # names by default without a very good reason. Use EXPORT_OK instead.
 475 # Do not simply export all your public functions/methods/constants.
 476 \@EXPORT = qw(
 477         @const_names
 478 );
 479 \$VERSION = '$TEMPLATE_VERSION';
 480
 481 END
 482
 483 print PM <<"END" unless $opt_c or $opt_X;
 484 sub AUTOLOAD {
 485     # This AUTOLOAD is used to 'autoload' constants from the constant()
 486     # XS function.  If a constant is not found then control is passed
 487     # to the AUTOLOAD in AutoLoader.
 488
 489     my \$constname;
 490     (\$constname = \$AUTOLOAD) =~ s/.*:://;
 491     croak "&$module::constant not defined" if \$constname eq 'constant';
 492     my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
 493     if (\$! != 0) {
 494         if (\$! =~ /Invalid/) {
 495             \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
 496             goto &AutoLoader::AUTOLOAD;
 497         }
 498         else {
 499                 croak "Your vendor has not defined $module macro \$constname";
 500         }
 501     }
 502     *\$AUTOLOAD = sub () { \$val };
 503     goto &\$AUTOLOAD;
 504 }
 505
 506 END
 507
 508 if( ! $opt_X ){ # print bootstrap, unless XS is disabled
 509         print PM <<"END";
 510 bootstrap $module \$VERSION;
 511 END
 512 }
 513
 514 if( $opt_P ){ # if POD is disabled
 515         $after = '__END__';
 516 }
 517 else {
 518         $after = '=cut';
 519 }
 520
 521 print PM <<"END";
 522
 523 # Preloaded methods go here.
 524
 525 # Autoload methods go after $after, and are processed by the autosplit program.
 526
 527 1;
 528 __END__
 529 END
 530
 531 $author = "A. U. Thor";
 532 $email = 'a.u.thor@a.galaxy.far.far.away';
 533
 534 my $const_doc = '';
 535 my $fdecl_doc = '';
 536 if (@const_names and not $opt_P) {
 537   $const_doc = <<EOD;
 538 \n=head1 Exported constants
 539
 540   @{[join "\n  ", @const_names]}
 541
 542 EOD
 543 }
 544 if (defined $fdecls and @$fdecls and not $opt_P) {
 545   $fdecl_doc = <<EOD;
 546 \n=head1 Exported functions
 547
 548   @{[join "\n  ", @$fdecls]}
 549
 550 EOD
 551 }
 552
 553 $pod = <<"END" unless $opt_P;
 554 ## Below is the stub of documentation for your module. You better edit it!
 555 #
 556 #=head1 NAME
 557 #
 558 #$module - Perl extension for blah blah blah
 559 #
 560 #=head1 SYNOPSIS
 561 #
 562 #  use $module;
 563 #  blah blah blah
 564 #
 565 #=head1 DESCRIPTION
 566 #
 567 #Stub documentation for $module was created by h2xs. It looks like the
 568 #author of the extension was negligent enough to leave the stub
 569 #unedited.
 570 #
 571 #Blah blah blah.
 572 #$const_doc$fdecl_doc
 573 #=head1 AUTHOR
 574 #
 575 #$author, $email
 576 #
 577 #=head1 SEE ALSO
 578 #
 579 #perl(1).
 580 #
 581 #=cut
 582 END
 583
 584 $pod =~ s/^\#//gm unless $opt_P;
 585 print PM $pod unless $opt_P;
 586
 587 close PM;
 588
 589
 590 if( ! $opt_X ){ # print XS, unless it is disabled
 591 warn "Writing $ext$modpname/$modfname.xs\n";
 592
 593 print XS <<"END";
 594 #include "EXTERN.h"
 595 #include "perl.h"
 596 #include "XSUB.h"
 597
 598 END
 599 if( @path_h ){
 600     foreach my $path_h (@path_h) {
 601         my($h) = $path_h;
 602         $h =~ s#^/usr/include/##;
 603         if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
 604         print XS qq{#include <$h>\n};
 605     }
 606     print XS "\n";
 607 }
 608
 609 if( ! $opt_c ){
 610 print XS <<"END";
 611 static int
 612 not_here(char *s)
 613 {
 614     croak("$module::%s not implemented on this architecture", s);
 615     return -1;
 616 }
 617
 618 static double
 619 constant(char *name, int arg)
 620 {
 621     errno = 0;
 622     switch (*name) {
 623 END
 624
 625 my(@AZ, @az, @under);
 626
 627 foreach(@const_names){
 628     @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/;
 629     @az = 'a' .. 'z' if !@az && /^[a-z]/;
 630     @under = '_'  if !@under && /^_/;
 631 }
 632
 633 foreach $letter (@AZ, @az, @under) {
 634
 635     last if $letter eq 'a' && !@const_names;
 636
 637     print XS "    case '$letter':\n";
 638     my($name);
 639     while (substr($const_names[0],0,1) eq $letter) {
 640         $name = shift(@const_names);
 641         $macro = $prefix{$name} ? "$opt_p$name" : $name;
 642         next if $const_xsub{$macro};
 643         print XS <<"END";
 644         if (strEQ(name, "$name"))
 645 #ifdef $macro
 646             return $macro;
 647 #else
 648             goto not_there;
 649 #endif
 650 END
 651     }
 652     print XS <<"END";
 653         break;
 654 END
 655 }
 656 print XS <<"END";
 657     }
 658     errno = EINVAL;
 659     return 0;
 660
 661 not_there:
 662     errno = ENOENT;
 663     return 0;
 664 }
 665
 666 END
 667 }
 668
 669 $prefix = "PREFIX = $opt_p" if defined $opt_p;
 670 # Now switch from C to XS by issuing the first MODULE declaration:
 671 print XS <<"END";
 672
 673 MODULE = $module                PACKAGE = $module               $prefix
 674
 675 END
 676
 677 foreach (sort keys %const_xsub) {
 678     print XS <<"END";
 679 char *
 680 $_()
 681
 682     CODE:
 683 #ifdef $_
 684     RETVAL = $_;
 685 #else
 686     croak("Your vendor has not defined the $module macro $_");
 687 #endif
 688
 689     OUTPUT:
 690     RETVAL
 691
 692 END
 693 }
 694
 695 # If a constant() function was written then output a corresponding
 696 # XS declaration:
 697 print XS <<"END" unless $opt_c;
 698
 699 double
 700 constant(name,arg)
 701         char *          name
 702         int             arg
 703
 704 END
 705
 706 my %seen_decl;
 707
 708
 709 sub print_decl {
 710   my $fh = shift;
 711   my $decl = shift;
 712   my ($type, $name, $args) = @$decl;
 713   return if $seen_decl{$name}++; # Need to do the same for docs as well?
 714
 715   my @argnames = map {$_->[1]} @$args;
 716   my @argtypes = map { normalize_type( $_->[0] ) } @$args;
 717   my @argarrays = map { $_->[4] || '' } @$args;
 718   my $numargs = @$args;
 719   if ($numargs and $argtypes[-1] eq '...') {
 720     $numargs--;
 721     $argnames[-1] = '...';
 722   }
 723   local $" = ', ';
 724   $type = normalize_type($type);
 725
 726   print $fh <<"EOP";
 727
 728 $type
 729 $name(@argnames)
 730 EOP
 731
 732   for $arg (0 .. $numargs - 1) {
 733     print $fh <<"EOP";
 734         $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
 735 EOP
 736   }
 737 }
 738
 739 # Should be called before any actual call to normalize_type().
 740 sub get_typemap {
 741   # We do not want to read ./typemap by obvios reasons.
 742   my @tm =  qw(../../../typemap ../../typemap ../typemap);
 743   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
 744   unshift @tm, $stdtypemap;
 745   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
 746   my $image;
 747
 748   foreach $typemap (@tm) {
 749     next unless -e $typemap ;
 750     # skip directories, binary files etc.
 751     warn " Scanning $typemap\n";
 752     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
 753       unless -T $typemap ;
 754     open(TYPEMAP, $typemap)
 755       or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
 756     my $mode = 'Typemap';
 757     while (<TYPEMAP>) {
 758       next if /^\s*\#/;
 759       if (/^INPUT\s*$/)   { $mode = 'Input'; next; }
 760       elsif (/^OUTPUT\s*$/)  { $mode = 'Output'; next; }
 761       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
 762       elsif ($mode eq 'Typemap') {
 763         next if /^\s*($|\#)/ ;
 764         if ( ($type, $image) =
 765              /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
 766              # This may reference undefined functions:
 767              and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
 768           normalize_type($type);
 769         }
 770       }
 771     }
 772     close(TYPEMAP) or die "Cannot close $typemap: $!";
 773   }
 774   %std_types = %types_seen;
 775   %types_seen = ();
 776 }
 777
 778
 779 sub normalize_type {
 780   my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*';
 781   my $type = shift;
 782   $type =~ s/$ignore_mods//go;
 783   $type =~ s/([\]\[()])/ \1 /g;
 784   $type =~ s/\s+/ /g;
 785   $type =~ s/\s+$//;
 786   $type =~ s/^\s+//;
 787   $type =~ s/\b\*/ */g;
 788   $type =~ s/\*\b/* /g;
 789   $type =~ s/\*\s+(?=\*)/*/g;
 790   $types_seen{$type}++
 791     unless $type eq '...' or $type eq 'void' or $std_types{$type};
 792   $type;
 793 }
 794
 795 if ($opt_x) {
 796     for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
 797 }
 798
 799 close XS;
 800
 801 if (%types_seen) {
 802   my $type;
 803   warn "Writing $ext$modpname/typemap\n";
 804   open TM, ">typemap" or die "Cannot open typemap file for write: $!";
 805
 806   for $type (keys %types_seen) {
 807     print TM $type, "\t" x (6 - int((length $type)/8)), "T_PTROBJ\n"
 808   }
 809
 810   close TM or die "Cannot close typemap file for write: $!";
 811 }
 812
 813 } # if( ! $opt_X )
 814
 815 warn "Writing $ext$modpname/Makefile.PL\n";
 816 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
 817
 818 print PL <<'END';
 819 use ExtUtils::MakeMaker;
 820 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
 821 # the contents of the Makefile that is written.
 822 END
 823 print PL "WriteMakefile(\n";
 824 print PL "    'NAME'    => '$module',\n";
 825 print PL "    'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n";
 826 if( ! $opt_X ){ # print C stuff, unless XS is disabled
 827   print PL "    'LIBS'  => ['$extralibs'],   # e.g., '-lm' \n";
 828   print PL "    'DEFINE'        => '',     # e.g., '-DHAVE_SOMETHING' \n";
 829   print PL "    'INC'   => '',     # e.g., '-I/usr/include/other' \n";
 830 }
 831 print PL ");\n";
 832 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
 833
 834 warn "Writing $ext$modpname/test.pl\n";
 835 open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
 836 print EX <<'_END_';
 837 # Before `make install' is performed this script should be runnable with
 838 # `make test'. After `make install' it should work as `perl test.pl'
 839
 840 ######################### We start with some black magic to print on failure.
 841
 842 # Change 1..1 below to 1..last_test_to_print .
 843 # (It may become useful if the test is moved to ./t subdirectory.)
 844
 845 BEGIN { $| = 1; print "1..1\n"; }
 846 END {print "not ok 1\n" unless $loaded;}
 847 _END_
 848 print EX <<_END_;
 849 use $module;
 850 _END_
 851 print EX <<'_END_';
 852 $loaded = 1;
 853 print "ok 1\n";
 854
 855 ######################### End of black magic.
 856
 857 # Insert your test code below (better if it prints "ok 13"
 858 # (correspondingly "not ok 13") depending on the success of chunk 13
 859 # of the test code):
 860
 861 _END_
 862 close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
 863
 864 warn "Writing $ext$modpname/Changes\n";
 865 open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
 866 print EX "Revision history for Perl extension $module.\n\n";
 867 print EX "$TEMPLATE_VERSION  ",scalar localtime,"\n";
 868 print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n";
 869 close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
 870
 871 warn "Writing $ext$modpname/MANIFEST\n";
 872 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
 873 @files = <*>;
 874 if (!@files) {
 875   eval {opendir(D,'.');};
 876   unless ($@) { @files = readdir(D); closedir(D); }
 877 }
 878 if (!@files) { @files = map {chomp && $_} `ls`; }
 879 if ($^O eq 'VMS') {
 880   foreach (@files) {
 881     # Clip trailing '.' for portability -- non-VMS OSs don't expect it
 882     s%\.$%%;
 883     # Fix up for case-sensitive file systems
 884     s/$modfname/$modfname/i && next;
 885     $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
 886     $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
 887   }
 888 }
 889 print MANI join("\n",@files), "\n";
 890 close MANI;
 891 !NO!SUBS!
 892
 893 close OUT or die "Can't close $file: $!";
 894 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 895 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 896 chdir $origdir;