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.18 $ ' =~ /\$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 #ifdef __cplusplus
 595 extern "C" {
 596 #endif
 597 #include "EXTERN.h"
 598 #include "perl.h"
 599 #include "XSUB.h"
 600 #ifdef __cplusplus
 601 }
 602 #endif
 603
 604 END
 605 if( @path_h ){
 606     foreach my $path_h (@path_h) {
 607         my($h) = $path_h;
 608         $h =~ s#^/usr/include/##;
 609         if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
 610         print XS qq{#include <$h>\n};
 611     }
 612     print XS "\n";
 613 }
 614
 615 if( ! $opt_c ){
 616 print XS <<"END";
 617 static int
 618 not_here(s)
 619 char *s;
 620 {
 621     croak("$module::%s not implemented on this architecture", s);
 622     return -1;
 623 }
 624
 625 static double
 626 constant(name, arg)
 627 char *name;
 628 int arg;
 629 {
 630     errno = 0;
 631     switch (*name) {
 632 END
 633
 634 my(@AZ, @az, @under);
 635
 636 foreach(@const_names){
 637     @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/;
 638     @az = 'a' .. 'z' if !@az && /^[a-z]/;
 639     @under = '_'  if !@under && /^_/;
 640 }
 641
 642 foreach $letter (@AZ, @az, @under) {
 643
 644     last if $letter eq 'a' && !@const_names;
 645
 646     print XS "    case '$letter':\n";
 647     my($name);
 648     while (substr($const_names[0],0,1) eq $letter) {
 649         $name = shift(@const_names);
 650         $macro = $prefix{$name} ? "$opt_p$name" : $name;
 651         next if $const_xsub{$macro};
 652         print XS <<"END";
 653         if (strEQ(name, "$name"))
 654 #ifdef $macro
 655             return $macro;
 656 #else
 657             goto not_there;
 658 #endif
 659 END
 660     }
 661     print XS <<"END";
 662         break;
 663 END
 664 }
 665 print XS <<"END";
 666     }
 667     errno = EINVAL;
 668     return 0;
 669
 670 not_there:
 671     errno = ENOENT;
 672     return 0;
 673 }
 674
 675 END
 676 }
 677
 678 $prefix = "PREFIX = $opt_p" if defined $opt_p;
 679 # Now switch from C to XS by issuing the first MODULE declaration:
 680 print XS <<"END";
 681
 682 MODULE = $module                PACKAGE = $module               $prefix
 683
 684 END
 685
 686 foreach (sort keys %const_xsub) {
 687     print XS <<"END";
 688 char *
 689 $_()
 690
 691     CODE:
 692 #ifdef $_
 693     RETVAL = $_;
 694 #else
 695     croak("Your vendor has not defined the $module macro $_");
 696 #endif
 697
 698     OUTPUT:
 699     RETVAL
 700
 701 END
 702 }
 703
 704 # If a constant() function was written then output a corresponding
 705 # XS declaration:
 706 print XS <<"END" unless $opt_c;
 707
 708 double
 709 constant(name,arg)
 710         char *          name
 711         int             arg
 712
 713 END
 714
 715 my %seen_decl;
 716
 717
 718 sub print_decl {
 719   my $fh = shift;
 720   my $decl = shift;
 721   my ($type, $name, $args) = @$decl;
 722   return if $seen_decl{$name}++; # Need to do the same for docs as well?
 723
 724   my @argnames = map {$_->[1]} @$args;
 725   my @argtypes = map { normalize_type( $_->[0] ) } @$args;
 726   my @argarrays = map { $_->[4] || '' } @$args;
 727   my $numargs = @$args;
 728   if ($numargs and $argtypes[-1] eq '...') {
 729     $numargs--;
 730     $argnames[-1] = '...';
 731   }
 732   local $" = ', ';
 733   $type = normalize_type($type);
 734
 735   print $fh <<"EOP";
 736
 737 $type
 738 $name(@argnames)
 739 EOP
 740
 741   for $arg (0 .. $numargs - 1) {
 742     print $fh <<"EOP";
 743         $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
 744 EOP
 745   }
 746 }
 747
 748 # Should be called before any actual call to normalize_type().
 749 sub get_typemap {
 750   # We do not want to read ./typemap by obvios reasons.
 751   my @tm =  qw(../../../typemap ../../typemap ../typemap);
 752   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
 753   unshift @tm, $stdtypemap;
 754   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
 755   my $image;
 756
 757   foreach $typemap (@tm) {
 758     next unless -e $typemap ;
 759     # skip directories, binary files etc.
 760     warn " Scanning $typemap\n";
 761     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
 762       unless -T $typemap ;
 763     open(TYPEMAP, $typemap)
 764       or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
 765     my $mode = 'Typemap';
 766     while (<TYPEMAP>) {
 767       next if /^\s*\#/;
 768       if (/^INPUT\s*$/)   { $mode = 'Input'; next; }
 769       elsif (/^OUTPUT\s*$/)  { $mode = 'Output'; next; }
 770       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
 771       elsif ($mode eq 'Typemap') {
 772         next if /^\s*($|\#)/ ;
 773         if ( ($type, $image) =
 774              /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
 775              # This may reference undefined functions:
 776              and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
 777           normalize_type($type);
 778         }
 779       }
 780     }
 781     close(TYPEMAP) or die "Cannot close $typemap: $!";
 782   }
 783   %std_types = %types_seen;
 784   %types_seen = ();
 785 }
 786
 787
 788 sub normalize_type {
 789   my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*';
 790   my $type = shift;
 791   $type =~ s/$ignore_mods//go;
 792   $type =~ s/([\]\[()])/ \1 /g;
 793   $type =~ s/\s+/ /g;
 794   $type =~ s/\s+$//;
 795   $type =~ s/^\s+//;
 796   $type =~ s/\b\*/ */g;
 797   $type =~ s/\*\b/* /g;
 798   $type =~ s/\*\s+(?=\*)/*/g;
 799   $types_seen{$type}++
 800     unless $type eq '...' or $type eq 'void' or $std_types{$type};
 801   $type;
 802 }
 803
 804 if ($opt_x) {
 805     for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
 806 }
 807
 808 close XS;
 809
 810 if (%types_seen) {
 811   my $type;
 812   warn "Writing $ext$modpname/typemap\n";
 813   open TM, ">typemap" or die "Cannot open typemap file for write: $!";
 814
 815   for $type (keys %types_seen) {
 816     print TM $type, "\t" x (6 - int((length $type)/8)), "T_PTROBJ\n"
 817   }
 818
 819   close TM or die "Cannot close typemap file for write: $!";
 820 }
 821
 822 } # if( ! $opt_X )
 823
 824 warn "Writing $ext$modpname/Makefile.PL\n";
 825 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
 826
 827 print PL <<'END';
 828 use ExtUtils::MakeMaker;
 829 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
 830 # the contents of the Makefile that is written.
 831 END
 832 print PL "WriteMakefile(\n";
 833 print PL "    'NAME'    => '$module',\n";
 834 print PL "    'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n";
 835 if( ! $opt_X ){ # print C stuff, unless XS is disabled
 836   print PL "    'LIBS'  => ['$extralibs'],   # e.g., '-lm' \n";
 837   print PL "    'DEFINE'        => '',     # e.g., '-DHAVE_SOMETHING' \n";
 838   print PL "    'INC'   => '',     # e.g., '-I/usr/include/other' \n";
 839 }
 840 print PL ");\n";
 841 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
 842
 843 warn "Writing $ext$modpname/test.pl\n";
 844 open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
 845 print EX <<'_END_';
 846 # Before `make install' is performed this script should be runnable with
 847 # `make test'. After `make install' it should work as `perl test.pl'
 848
 849 ######################### We start with some black magic to print on failure.
 850
 851 # Change 1..1 below to 1..last_test_to_print .
 852 # (It may become useful if the test is moved to ./t subdirectory.)
 853
 854 BEGIN { $| = 1; print "1..1\n"; }
 855 END {print "not ok 1\n" unless $loaded;}
 856 _END_
 857 print EX <<_END_;
 858 use $module;
 859 _END_
 860 print EX <<'_END_';
 861 $loaded = 1;
 862 print "ok 1\n";
 863
 864 ######################### End of black magic.
 865
 866 # Insert your test code below (better if it prints "ok 13"
 867 # (correspondingly "not ok 13") depending on the success of chunk 13
 868 # of the test code):
 869
 870 _END_
 871 close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
 872
 873 warn "Writing $ext$modpname/Changes\n";
 874 open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
 875 print EX "Revision history for Perl extension $module.\n\n";
 876 print EX "$TEMPLATE_VERSION  ",scalar localtime,"\n";
 877 print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n";
 878 close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
 879
 880 warn "Writing $ext$modpname/MANIFEST\n";
 881 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
 882 @files = <*>;
 883 if (!@files) {
 884   eval {opendir(D,'.');};
 885   unless ($@) { @files = readdir(D); closedir(D); }
 886 }
 887 if (!@files) { @files = map {chomp && $_} `ls`; }
 888 if ($^O eq 'VMS') {
 889   foreach (@files) {
 890     # Clip trailing '.' for portability -- non-VMS OSs don't expect it
 891     s%\.$%%;
 892     # Fix up for case-sensitive file systems
 893     s/$modfname/$modfname/i && next;
 894     $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
 895     $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
 896   }
 897 }
 898 print MANI join("\n",@files), "\n";
 899 close MANI;
 900 !NO!SUBS!
 901
 902 close OUT or die "Can't close $file: $!";
 903 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 904 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 905 chdir $origdir;