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