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