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