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