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