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