utils/h2xs.PL

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