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<-M> I<regular expression>
  87
  88 selects functions/macros to process.
  89
  90 =item B<-O>
  91
  92 Allows a pre-existing extension directory to be overwritten.
  93
  94 =item B<-P>
  95
  96 Omit the autogenerated stub POD section.
  97
  98 =item B<-X>
  99
 100 Omit the XS portion.  Used to generate templates for a module which is not
 101 XS-based.  C<-c> and C<-f> are implicitly enabled.
 102
 103 =item B<-c>
 104
 105 Omit C<constant()> from the .xs file and corresponding specialised
 106 C<AUTOLOAD> from the .pm file.
 107
 108 =item B<-d>
 109
 110 Turn on debugging messages.
 111
 112 =item B<-f>
 113
 114 Allows an extension to be created for a header even if that header is
 115 not found in standard include directories.
 116
 117 =item B<-h>
 118
 119 Print the usage, help and version for this h2xs and exit.
 120
 121 =item B<-n> I<module_name>
 122
 123 Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
 124
 125 =item B<-o> I<regular expression>
 126
 127 Use "opaque" data type for the C types matched by the regular
 128 expression, even if these types are C<typedef>-equivalent to types
 129 from typemaps.  Should not be used without B<-x>.
 130
 131 This may be useful since, say, types which are C<typedef>-equivalent
 132 to integers may represent OS-related handles, and one may want to work
 133 with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
 134 Use C<-o .> if you want to handle all the C<typedef>ed types as opaque types.
 135
 136 The type-to-match is whitewashed (except for commas, which have no
 137 whitespace before them, and multiple C<*> which have no whitespace
 138 between them).
 139
 140 =item B<-p> I<prefix>
 141
 142 Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_>
 143 This sets up the XS B<PREFIX> keyword and removes the prefix from functions that are
 144 autoloaded via the C<constant()> mechanism.
 145
 146 =item B<-s> I<sub1,sub2>
 147
 148 Create a perl subroutine for the specified macros rather than autoload with the constant() subroutine.
 149 These macros are assumed to have a return type of B<char *>, e.g., S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
 150
 151 =item B<-v> I<version>
 152
 153 Specify a version number for this extension.  This version number is added
 154 to the templates.  The default is 0.01.
 155
 156 =item B<-x>
 157
 158 Automatically generate XSUBs basing on function declarations in the
 159 header file.  The package C<C::Scan> should be installed. If this
 160 option is specified, the name of the header file may look like
 161 C<NAME1,NAME2>. In this case NAME1 is used instead of the specified string,
 162 but XSUBs are emitted only for the declarations included from file NAME2.
 163
 164 Note that some types of arguments/return-values for functions may
 165 result in XSUB-declarations/typemap-entries which need
 166 hand-editing. Such may be objects which cannot be converted from/to a
 167 pointer (like C<long long>), pointers to functions, or arrays.  See
 168 also the section on L<LIMITATIONS of B<-x>>.
 169
 170 =back
 171
 172 =head1 EXAMPLES
 173
 174
 175         # Default behavior, extension is Rusers
 176         h2xs rpcsvc/rusers
 177
 178         # Same, but extension is RUSERS
 179         h2xs -n RUSERS rpcsvc/rusers
 180
 181         # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
 182         h2xs rpcsvc::rusers
 183
 184         # Extension is ONC::RPC.  Still finds <rpcsvc/rusers.h>
 185         h2xs -n ONC::RPC rpcsvc/rusers
 186
 187         # Without constant() or AUTOLOAD
 188         h2xs -c rpcsvc/rusers
 189
 190         # Creates templates for an extension named RPC
 191         h2xs -cfn RPC
 192
 193         # Extension is ONC::RPC.
 194         h2xs -cfn ONC::RPC
 195
 196         # Makefile.PL will look for library -lrpc in
 197         # additional directory /opt/net/lib
 198         h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
 199
 200         # Extension is DCE::rgynbase
 201         # prefix "sec_rgy_" is dropped from perl function names
 202         h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
 203
 204         # Extension is DCE::rgynbase
 205         # prefix "sec_rgy_" is dropped from perl function names
 206         # subroutines are created for sec_rgy_wildcard_name and sec_rgy_wildcard_sid
 207         h2xs -n DCE::rgynbase -p sec_rgy_ \
 208         -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
 209
 210         # Make XS without defines in perl.h, but with function declarations
 211         # visible from perl.h. Name of the extension is perl1.
 212         # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
 213         # Extra backslashes below because the string is passed to shell.
 214         # Note that a directory with perl header files would
 215         #  be added automatically to include path.
 216         h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
 217
 218         # Same with function declaration in proto.h as visible from perl.h.
 219         h2xs -xAn perl2 perl.h,proto.h
 220
 221         # Same but select only functions which match /^av_/
 222         h2xs -M '^av_' -xAn perl2 perl.h,proto.h
 223
 224         # Same but treat SV* etc as "opaque" types
 225         h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h
 226
 227 =head1 ENVIRONMENT
 228
 229 No environment variables are used.
 230
 231 =head1 AUTHOR
 232
 233 Larry Wall and others
 234
 235 =head1 SEE ALSO
 236
 237 L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
 238
 239 =head1 DIAGNOSTICS
 240
 241 The usual warnings if it cannot read or write the files involved.
 242
 243 =head1 LIMITATIONS of B<-x>
 244
 245 F<h2xs> would not distinguish whether an argument to a C function
 246 which is of the form, say, C<int *>, is an input, output, or
 247 input/output parameter.  In particular, argument declarations of the
 248 form
 249
 250     int
 251     foo(n)
 252         int *n
 253
 254 should be better rewritten as
 255
 256     int
 257     foo(n)
 258         int &n
 259
 260 if C<n> is an input parameter.
 261
 262 Additionally, F<h2xs> has no facilities to intuit that a function
 263
 264    int
 265    foo(addr,l)
 266         char *addr
 267         int   l
 268
 269 takes a pair of address and length of data at this address, so it is better
 270 to rewrite this function as
 271
 272     int
 273     foo(sv)
 274         SV *addr
 275     PREINIT:
 276         STRLEN len;
 277         char *s;
 278     CODE:
 279         s = SvPV(sv,len);
 280         RETVAL = foo(s, len);
 281     OUTPUT:
 282         RETVAL
 283
 284 or alternately
 285
 286     static int
 287     my_foo(SV *sv)
 288     {
 289         STRLEN len;
 290         char *s = SvPV(sv,len);
 291
 292         return foo(s, len);
 293     }
 294
 295     MODULE = foo        PACKAGE = foo   PREFIX = my_
 296
 297     int
 298     foo(sv)
 299         SV *sv
 300
 301 See L<perlxs> and L<perlxstut> for additional details.
 302
 303 =cut
 304
 305 my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/;
 306 my $TEMPLATE_VERSION = '0.01';
 307 my @ARGS = @ARGV;
 308
 309 use Getopt::Std;
 310
 311 sub usage{
 312         warn "@_\n" if @_;
 313     die "h2xs [-ACOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]]
 314 version: $H2XS_VERSION
 315     -A   Omit all autoloading facilities (implies -c).
 316     -C   Omit creating the Changes file, add HISTORY heading to stub POD.
 317     -F   Additional flags for C preprocessor (used with -x).
 318     -M   Mask to select C functions/macros (default is select all).
 319     -O   Allow overwriting of a pre-existing extension directory.
 320     -P   Omit the stub POD section.
 321     -X   Omit the XS portion (implies both -c and -f).
 322     -c   Omit the constant() function and specialised AUTOLOAD from the XS file.
 323     -d   Turn on debugging messages.
 324     -f   Force creation of the extension even if the C header does not exist.
 325     -h   Display this help message
 326     -n   Specify a name to use for the extension (recommended).
 327     -o   Regular expression for \"opaque\" types.
 328     -p   Specify a prefix which should be removed from the Perl function names.
 329     -s   Create subroutines for specified macros.
 330     -v   Specify a version number for this extension.
 331     -x   Autogenerate XSUBs using C::Scan.
 332 extra_libraries
 333          are any libraries that might be needed for loading the
 334          extension, e.g. -lm would try to link in the math library.
 335 ";
 336 }
 337
 338
 339 getopts("ACF:M:OPXcdfhn:o:p:s:v:x") || usage;
 340
 341 usage if $opt_h;
 342
 343 if( $opt_v ){
 344         $TEMPLATE_VERSION = $opt_v;
 345 }
 346
 347 # -A implies -c.
 348 $opt_c = 1 if $opt_A;
 349
 350 # -X implies -c and -f
 351 $opt_c = $opt_f = 1 if $opt_X;
 352
 353 %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
 354
 355 while (my $arg = shift) {
 356     if ($arg =~ /^-l/i) {
 357         $extralibs = "$arg @ARGV";
 358         last;
 359     }
 360     push(@path_h, $arg);
 361 }
 362
 363 usage "Must supply header file or module name\n"
 364         unless (@path_h or $opt_n);
 365
 366 my $fmask;
 367 my $omask;
 368
 369 $fmask = qr{$opt_M} if defined $opt_M;
 370 $tmask = qr{$opt_o} if defined $opt_o;
 371 my $tmask_all = $tmask && $opt_o eq '.';
 372
 373 if ($opt_x) {
 374   eval {require C::Scan; 1}
 375     or die <<EOD;
 376 C::Scan required if you use -x option.
 377 To install C::Scan, execute
 378    perl -MCPAN -e "install C::Scan"
 379 EOD
 380   unless ($tmask_all) {
 381     $C::Scan::VERSION >= 0.70
 382       or die <<EOD;
 383 C::Scan v. 0.70 or later required unless you use -o . option.
 384 You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
 385 To install C::Scan, execute
 386    perl -MCPAN -e "install C::Scan"
 387 EOD
 388   }
 389 } elsif ($opt_o or $opt_F) {
 390   warn <<EOD;
 391 Options -o and -F do not make sense without -x.
 392 EOD
 393 }
 394
 395 my %seen_define;
 396 my %prefixless;
 397
 398 if( @path_h ){
 399     use Config;
 400     use File::Spec;
 401     my @paths;
 402     if ($^O eq 'VMS') {  # Consider overrides of default location
 403       @paths = qw( Sys\$Library VAXC$Include );
 404       push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
 405       push @paths, qw( DECC$Library_Include DECC$System_Include );
 406     } else {
 407       @paths = (File::Spec->curdir(), $Config{usrinc},
 408                 (split ' ', $Config{locincpth}), '/usr/include');
 409     }
 410     foreach my $path_h (@path_h) {
 411         $name ||= $path_h;
 412     if( $path_h =~ s#::#/#g && $opt_n ){
 413         warn "Nesting of headerfile ignored with -n\n";
 414     }
 415     $path_h .= ".h" unless $path_h =~ /\.h$/;
 416     $fullpath = $path_h;
 417     $path_h =~ s/,.*$// if $opt_x;
 418
 419     if (not -f $path_h) {
 420       my $tmp_path_h = $path_h;
 421       for my $dir (@paths) {
 422         last if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
 423       }
 424     }
 425
 426     if (!$opt_c) {
 427       die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h );
 428       # Scan the header file (we should deal with nested header files)
 429       # Record the names of simple #define constants into const_names
 430             # Function prototypes are processed below.
 431       open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
 432     defines:
 433       while (<CH>) {
 434         if (/^#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) {
 435             my $def = $1;
 436             my $rest = $2;
 437             $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
 438             $rest =~ s/^\s+//;
 439             $rest =~ s/\s+$//;
 440             # Cannot do: (-1) and ((LHANDLE)3) are OK:
 441             #print("Skip non-wordy $def => $rest\n"),
 442             #  next defines if $rest =~ /[^\w\$]/;
 443             if ($rest =~ /"/) {
 444               print("Skip stringy $def => $rest\n") if $opt_d;
 445               next defines;
 446             }
 447             print "Matched $_ ($def)\n" if $opt_d;
 448             $seen_define{$def} = $rest;
 449             $_ = $def;
 450             next if /^_.*_h_*$/i; # special case, but for what?
 451             if (defined $opt_p) {
 452               if (!/^$opt_p(\d)/) {
 453                 ++$prefix{$_} if s/^$opt_p//;
 454               }
 455               else {
 456                 warn "can't remove $opt_p prefix from '$_'!\n";
 457               }
 458             }
 459             $prefixless{$def} = $_;
 460             if (!$fmask or /$fmask/) {
 461                 print "... Passes mask of -M.\n" if $opt_d and $fmask;
 462                 $const_names{$_}++;
 463             }
 464           }
 465       }
 466       close(CH);
 467     }
 468     }
 469 }
 470
 471
 472 $module = $opt_n || do {
 473         $name =~ s/\.h$//;
 474         if( $name !~ /::/ ){
 475                 $name =~ s#^.*/##;
 476                 $name = "\u$name";
 477         }
 478         $name;
 479 };
 480
 481 (chdir 'ext', $ext = 'ext/') if -d 'ext';
 482
 483 if( $module =~ /::/ ){
 484         $nested = 1;
 485         @modparts = split(/::/,$module);
 486         $modfname = $modparts[-1];
 487         $modpname = join('/',@modparts);
 488 }
 489 else {
 490         $nested = 0;
 491         @modparts = ();
 492         $modfname = $modpname = $module;
 493 }
 494
 495
 496 if ($opt_O) {
 497         warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
 498 } else {
 499         die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
 500 }
 501 if( $nested ){
 502         $modpath = "";
 503         foreach (@modparts){
 504                 mkdir("$modpath$_", 0777);
 505                 $modpath .= "$_/";
 506         }
 507 }
 508 mkdir($modpname, 0777);
 509 chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
 510
 511 my %types_seen;
 512 my %std_types;
 513 my $fdecls = [];
 514 my $fdecls_parsed = [];
 515 my $typedef_rex;
 516 my %typedefs_pre;
 517 my %known_fnames;
 518
 519 if( ! $opt_X ){  # use XS, unless it was disabled
 520   open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
 521   if ($opt_x) {
 522     require Config;             # Run-time directive
 523     warn "Scanning typemaps...\n";
 524     get_typemap();
 525     my $c;
 526     my $filter;
 527     foreach my $filename (@path_h) {
 528       my $addflags = $opt_F || '';
 529       if ($fullpath =~ /,/) {
 530         $filename = $`;
 531         $filter = $';
 532       }
 533       warn "Scanning $filename for functions...\n";
 534       $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
 535         'add_cppflags' => $addflags;
 536       $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
 537
 538       push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
 539       push(@$fdecls, @{$c->get('fdecls')});
 540     }
 541     %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
 542     if ($fmask) {
 543       my @good;
 544       for my $i (0..$#$fdecls_parsed) {
 545         next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
 546         push @good, $i;
 547         print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
 548           if $opt_d;
 549       }
 550       $fdecls = [@$fdecls[@good]];
 551       $fdecls_parsed = [@$fdecls_parsed[@good]];
 552     }
 553     unless ($tmask_all) {
 554       warn "Scanning $filename for typedefs...\n";
 555       my $td = $c->get('typedef_hash');
 556       # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
 557       my @good_td = grep $td->{$_}[1] eq '', keys %$td;
 558       @typedefs_pre{@good_td}  = map $_->[0], @$td{@good_td};
 559       { local $" = '|';
 560         $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b);
 561       }
 562     }
 563     # Remove macros which expand to typedefs
 564     my @td = @{$c->get('typedefs_maybe')};
 565     print "Typedefs are @td.\n" if $opt_d;
 566     my %td = map {($_, $_)} @td;
 567     # Add some other possible but meaningless values for macros
 568     for my $k (qw(char double float int long short unsigned signed void)) {
 569       $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
 570     }
 571     # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
 572     my $n = 0;
 573     my %bad_macs;
 574     while (keys %td > $n) {
 575       $n = keys %td;
 576       my ($k, $v);
 577       while (($k, $v) = each %seen_define) {
 578         # print("found '$k'=>'$v'\n"),
 579         $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
 580       }
 581     }
 582     # Now %bad_macs contains names of bad macros
 583     for my $k (keys %bad_macs) {
 584       delete $const_names{$prefixless{$k}};
 585       print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
 586     }
 587   }
 588 }
 589 @const_names = sort keys %const_names;
 590
 591 open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
 592
 593 $" = "\n\t";
 594 warn "Writing $ext$modpname/$modfname.pm\n";
 595
 596 print PM <<"END";
 597 package $module;
 598
 599 use strict;
 600 END
 601
 602 if( $opt_X || $opt_c || $opt_A ){
 603         # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD
 604         print PM <<'END';
 605 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
 606 END
 607 }
 608 else{
 609         # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
 610         # will want Carp.
 611         print PM <<'END';
 612 use Carp;
 613 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);
 614 END
 615 }
 616
 617 print PM <<'END';
 618
 619 require Exporter;
 620 END
 621
 622 print PM <<"END" if ! $opt_X;  # use DynaLoader, unless XS was disabled
 623 require DynaLoader;
 624 END
 625
 626
 627 # Are we using AutoLoader or not?
 628 unless ($opt_A) { # no autoloader whatsoever.
 629         unless ($opt_c) { # we're doing the AUTOLOAD
 630                 print PM "use AutoLoader;\n";
 631         }
 632         else {
 633                 print PM "use AutoLoader qw(AUTOLOAD);\n"
 634         }
 635 }
 636
 637 # Determine @ISA.
 638 my $myISA = '@ISA = qw(Exporter';       # We seem to always want this.
 639 $myISA .= ' DynaLoader'         unless $opt_X;  # no XS
 640 $myISA .= ');';
 641 print PM "\n$myISA\n\n";
 642
 643 print PM<<"END";
 644 # Items to export into callers namespace by default. Note: do not export
 645 # names by default without a very good reason. Use EXPORT_OK instead.
 646 # Do not simply export all your public functions/methods/constants.
 647
 648 # This allows declaration       use $module ':all';
 649 # If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
 650 # will save memory.
 651 %EXPORT_TAGS = ( ':all' => [ qw(
 652         @const_names
 653 ) ] );
 654
 655 \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{':all'} } );
 656
 657 \@EXPORT = (
 658
 659 );
 660 \$VERSION = '$TEMPLATE_VERSION';
 661
 662 END
 663
 664 print PM <<"END" unless $opt_c or $opt_X;
 665 sub AUTOLOAD {
 666     # This AUTOLOAD is used to 'autoload' constants from the constant()
 667     # XS function.  If a constant is not found then control is passed
 668     # to the AUTOLOAD in AutoLoader.
 669
 670     my \$constname;
 671     (\$constname = \$AUTOLOAD) =~ s/.*:://;
 672     croak "&$module::constant not defined" if \$constname eq 'constant';
 673     my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
 674     if (\$! != 0) {
 675         if (\$! =~ /Invalid/ || \$!{EINVAL}) {
 676             \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
 677             goto &AutoLoader::AUTOLOAD;
 678         }
 679         else {
 680                 croak "Your vendor has not defined $module macro \$constname";
 681         }
 682     }
 683     {  no strict 'refs';
 684        # Next line doesn't help with older Perls; in newers: no such warnings
 685        # local \$^W = 0;                # Prototype mismatch: sub XXX vs ()
 686        *\$AUTOLOAD = sub () { \$val };
 687     }
 688     goto &\$AUTOLOAD;
 689 }
 690
 691 END
 692
 693 if( ! $opt_X ){ # print bootstrap, unless XS is disabled
 694         print PM <<"END";
 695 bootstrap $module \$VERSION;
 696 END
 697 }
 698
 699 if( $opt_P ){ # if POD is disabled
 700         $after = '__END__';
 701 }
 702 else {
 703         $after = '=cut';
 704 }
 705
 706 print PM <<"END";
 707
 708 # Preloaded methods go here.
 709 END
 710
 711 print PM <<"END" unless $opt_A;
 712
 713 # Autoload methods go after $after, and are processed by the autosplit program.
 714 END
 715
 716 print PM <<"END";
 717
 718 1;
 719 __END__
 720 END
 721
 722 $author = "A. U. Thor";
 723 $email = 'a.u.thor@a.galaxy.far.far.away';
 724
 725 my $revhist = '';
 726 $revhist = <<EOT if $opt_C;
 727
 728 =head1 HISTORY
 729
 730 =over 8
 731
 732 =item $TEMPLATE_VERSION
 733
 734 Original version; created by h2xs $H2XS_VERSION with options
 735
 736   @ARGS
 737
 738 =back
 739
 740 EOT
 741
 742 my $exp_doc = <<EOD;
 743
 744 =head2 EXPORT
 745
 746 None by default.
 747
 748 EOD
 749 if (@const_names and not $opt_P) {
 750   $exp_doc .= <<EOD;
 751 =head2 Exportable constants
 752
 753   @{[join "\n  ", @const_names]}
 754
 755 EOD
 756 }
 757 if (defined $fdecls and @$fdecls and not $opt_P) {
 758   my @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
 759
 760   $exp_doc .= <<EOD;
 761 =head2 Exportable functions
 762
 763   @{[join "\n  ", @known_fnames{@fnames}]}
 764
 765 EOD
 766 }
 767
 768 $pod = <<"END" unless $opt_P;
 769 ## Below is the stub of documentation for your module. You better edit it!
 770 #
 771 #=head1 NAME
 772 #
 773 #$module - Perl extension for blah blah blah
 774 #
 775 #=head1 SYNOPSIS
 776 #
 777 #  use $module;
 778 #  blah blah blah
 779 #
 780 #=head1 DESCRIPTION
 781 #
 782 #Stub documentation for $module was created by h2xs. It looks like the
 783 #author of the extension was negligent enough to leave the stub
 784 #unedited.
 785 #
 786 #Blah blah blah.
 787 #$exp_doc$revhist
 788 #=head1 AUTHOR
 789 #
 790 #$author, $email
 791 #
 792 #=head1 SEE ALSO
 793 #
 794 #perl(1).
 795 #
 796 #=cut
 797 END
 798
 799 $pod =~ s/^\#//gm unless $opt_P;
 800 print PM $pod unless $opt_P;
 801
 802 close PM;
 803
 804
 805 if( ! $opt_X ){ # print XS, unless it is disabled
 806 warn "Writing $ext$modpname/$modfname.xs\n";
 807
 808 print XS <<"END";
 809 #include "EXTERN.h"
 810 #include "perl.h"
 811 #include "XSUB.h"
 812
 813 END
 814 if( @path_h ){
 815     foreach my $path_h (@path_h) {
 816         my($h) = $path_h;
 817         $h =~ s#^/usr/include/##;
 818         if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
 819         print XS qq{#include <$h>\n};
 820     }
 821     print XS "\n";
 822 }
 823
 824 my %pointer_typedefs;
 825 my %struct_typedefs;
 826
 827 sub td_is_pointer {
 828   my $type = shift;
 829   my $out = $pointer_typedefs{$type};
 830   return $out if defined $out;
 831   my $otype = $type;
 832   $out = ($type =~ /\*$/);
 833   # This converts only the guys which do not have trailing part in the typedef
 834   if (not $out
 835       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
 836     $type = normalize_type($type);
 837     print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
 838       if $opt_d;
 839     $out = td_is_pointer($type);
 840   }
 841   return ($pointer_typedefs{$otype} = $out);
 842 }
 843
 844 sub td_is_struct {
 845   my $type = shift;
 846   my $out = $struct_typedefs{$type};
 847   return $out if defined $out;
 848   my $otype = $type;
 849   $out = ($type =~ /^struct\b/) && !td_is_pointer($type);
 850   # This converts only the guys which do not have trailing part in the typedef
 851   if (not $out
 852       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
 853     $type = normalize_type($type);
 854     print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
 855       if $opt_d;
 856     $out = td_is_struct($type);
 857   }
 858   return ($struct_typedefs{$otype} = $out);
 859 }
 860
 861 # Some macros will bomb if you try to return them from a double-returning func.
 862 # Say, ((char *)0), or strlen (if somebody #define STRLEN strlen).
 863 # Fortunately, we can detect both these cases...
 864 sub protect_convert_to_double {
 865   my $in = shift;
 866   my $val;
 867   return '' unless defined ($val = $seen_define{$in});
 868   return '(IV)' if $known_fnames{$val};
 869   # OUT_t of ((OUT_t)-1):
 870   return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/;
 871   td_is_pointer($2) ? '(IV)' : '';
 872 }
 873
 874 # For each of the generated functions, length($pref) leading
 875 # letters are already checked.  Moreover, it is recommended that
 876 # the generated functions uses switch on letter at offset at least
 877 # $off + length($pref).
 878 #
 879 # The given list has length($pref) chars removed at front, it is
 880 # guarantied that $off leading chars in the rest are the same for all
 881 # elts of the list.
 882 #
 883 # Returns: how at which offset it was decided to make a switch, or -1 if none.
 884
 885 sub write_const;
 886
 887 sub write_const {
 888   my ($fh, $pref, $off, $list) = (shift,shift,shift,shift);
 889   my %leading;
 890   my $offarg = length $pref;
 891
 892   if (@$list == 0) {            # Can happen on the initial iteration only
 893     print $fh <<"END";
 894 static double
 895 constant(char *name, int arg)
 896 {
 897     errno = EINVAL;
 898     return 0;
 899 }
 900 END
 901     return -1;
 902   }
 903
 904   if (@$list == 1) {            # Can happen on the initial iteration only
 905     my $protect = protect_convert_to_double("$pref$list->[0]");
 906
 907     print $fh <<"END";
 908 static double
 909 constant(char *name, int arg)
 910 {
 911     if (strEQ(name + $offarg, "$list->[0]")) {  /* $pref removed */
 912 #ifdef $pref$list->[0]
 913         return $protect$pref$list->[0];
 914 #else
 915         errno = ENOENT;
 916         return 0;
 917 #endif
 918     }
 919     errno = EINVAL;
 920     return 0;
 921 }
 922 END
 923     return -1;
 924   }
 925
 926   for my $n (@$list) {
 927     my $c = substr $n, $off, 1;
 928     $leading{$c} = [] unless exists $leading{$c};
 929     push @{$leading{$c}}, substr $n, $off + 1;
 930   }
 931
 932   if (keys(%leading) == 1) {
 933     return 1 + write_const $fh, $pref, $off + 1, $list;
 934   }
 935
 936   my $leader = substr $list->[0], 0, $off;
 937   foreach $letter (keys %leading) {
 938     write_const $fh, "$pref$leader$letter", 0, $leading{$letter}
 939       if @{$leading{$letter}} > 1;
 940   }
 941
 942   my $npref = "_$pref";
 943   $npref = '' if $pref eq '';
 944
 945   print $fh <<"END";
 946 static double
 947 constant$npref(char *name, int arg)
 948 {
 949     errno = 0;
 950     switch (name[$offarg + $off]) {
 951 END
 952
 953   foreach $letter (sort keys %leading) {
 954     my $let = $letter;
 955     $let = '\0' if $letter eq '';
 956
 957     print $fh <<EOP;
 958     case '$let':
 959 EOP
 960     if (@{$leading{$letter}} > 1) {
 961       # It makes sense to call a function
 962       if ($off) {
 963         print $fh <<EOP;
 964         if (!strnEQ(name + $offarg,"$leader", $off))
 965             break;
 966 EOP
 967       }
 968       print $fh <<EOP;
 969         return constant_$pref$leader$letter(name, arg);
 970 EOP
 971     } else {
 972       # Do it ourselves
 973       my $protect
 974         = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]");
 975
 976       print $fh <<EOP;
 977         if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) {      /* $pref removed */
 978 #ifdef $pref$leader$letter$leading{$letter}[0]
 979             return $protect$pref$leader$letter$leading{$letter}[0];
 980 #else
 981             goto not_there;
 982 #endif
 983         }
 984 EOP
 985     }
 986   }
 987   print $fh <<"END";
 988     }
 989     errno = EINVAL;
 990     return 0;
 991
 992 not_there:
 993     errno = ENOENT;
 994     return 0;
 995 }
 996
 997 END
 998
 999 }
1000
1001 if( ! $opt_c ) {
1002   print XS <<"END";
1003 static int
1004 not_here(char *s)
1005 {
1006     croak("$module::%s not implemented on this architecture", s);
1007     return -1;
1008 }
1009
1010 END
1011
1012   write_const(\*XS, '', 0, \@const_names);
1013 }
1014
1015 $prefix = "PREFIX = $opt_p" if defined $opt_p;
1016 # Now switch from C to XS by issuing the first MODULE declaration:
1017 print XS <<"END";
1018
1019 MODULE = $module                PACKAGE = $module               $prefix
1020
1021 END
1022
1023 foreach (sort keys %const_xsub) {
1024     print XS <<"END";
1025 char *
1026 $_()
1027
1028     CODE:
1029 #ifdef $_
1030     RETVAL = $_;
1031 #else
1032     croak("Your vendor has not defined the $module macro $_");
1033 #endif
1034
1035     OUTPUT:
1036     RETVAL
1037
1038 END
1039 }
1040
1041 # If a constant() function was written then output a corresponding
1042 # XS declaration:
1043 print XS <<"END" unless $opt_c;
1044
1045 double
1046 constant(name,arg)
1047         char *          name
1048         int             arg
1049
1050 END
1051
1052 my %seen_decl;
1053 my %typemap;
1054
1055 sub print_decl {
1056   my $fh = shift;
1057   my $decl = shift;
1058   my ($type, $name, $args) = @$decl;
1059   return if $seen_decl{$name}++; # Need to do the same for docs as well?
1060
1061   my @argnames = map {$_->[1]} @$args;
1062   my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
1063   my @argarrays = map { $_->[4] || '' } @$args;
1064   my $numargs = @$args;
1065   if ($numargs and $argtypes[-1] eq '...') {
1066     $numargs--;
1067     $argnames[-1] = '...';
1068   }
1069   local $" = ', ';
1070   $type = normalize_type($type, 1);
1071
1072   print $fh <<"EOP";
1073
1074 $type
1075 $name(@argnames)
1076 EOP
1077
1078   for $arg (0 .. $numargs - 1) {
1079     print $fh <<"EOP";
1080         $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
1081 EOP
1082   }
1083 }
1084
1085 # Should be called before any actual call to normalize_type().
1086 sub get_typemap {
1087   # We do not want to read ./typemap by obvios reasons.
1088   my @tm =  qw(../../../typemap ../../typemap ../typemap);
1089   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
1090   unshift @tm, $stdtypemap;
1091   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
1092   my $image;
1093
1094   # Start with useful default values
1095   $typemap{float} = 'T_DOUBLE';
1096
1097   foreach $typemap (@tm) {
1098     next unless -e $typemap ;
1099     # skip directories, binary files etc.
1100     warn " Scanning $typemap\n";
1101     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1102       unless -T $typemap ;
1103     open(TYPEMAP, $typemap)
1104       or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1105     my $mode = 'Typemap';
1106     while (<TYPEMAP>) {
1107       next if /^\s*\#/;
1108       if (/^INPUT\s*$/)   { $mode = 'Input'; next; }
1109       elsif (/^OUTPUT\s*$/)  { $mode = 'Output'; next; }
1110       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1111       elsif ($mode eq 'Typemap') {
1112         next if /^\s*($|\#)/ ;
1113         if ( ($type, $image) =
1114              /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1115              # This may reference undefined functions:
1116              and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
1117           $typemap{normalize_type($type)} = $image;
1118         }
1119       }
1120     }
1121     close(TYPEMAP) or die "Cannot close $typemap: $!";
1122   }
1123   %std_types = %types_seen;
1124   %types_seen = ();
1125 }
1126
1127
1128 sub normalize_type {            # Second arg: do not strip const's before \*
1129   my $type = shift;
1130   # XXXX function-pointer declarations?
1131   my $keep_deep_const = shift() ? '\b(?![^(,)]*\*)' : '';
1132   my $ignore_mods
1133     = "(?:\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\b\s*)*";
1134   $type =~ s/$ignore_mods//go;
1135   $type =~ s/([^\s\w])/ \1 /g;
1136   $type =~ s/\s+$//;
1137   $type =~ s/^\s+//;
1138   $type =~ s/\s+/ /g;
1139   $type =~ s/\* (?=\*)/*/g;
1140   $type =~ s/\. \. \./.../g;
1141   $type =~ s/ ,/,/g;
1142   $types_seen{$type}++
1143     unless $type eq '...' or $type eq 'void' or $std_types{$type};
1144   $type;
1145 }
1146
1147 my $need_opaque;
1148
1149 sub assign_typemap_entry {
1150   my $type = shift;
1151   my $otype = $type;
1152   my $entry;
1153   if ($tmask and $type =~ /$tmask/) {
1154     print "Type $type matches -o mask\n" if $opt_d;
1155     $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1156   }
1157   elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1158     $type = normalize_type $type;
1159     print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1160     $entry = assign_typemap_entry($type);
1161   }
1162   $entry ||= $typemap{$otype}
1163     || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1164   $typemap{$otype} = $entry;
1165   $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1166   return $entry;
1167 }
1168
1169 if ($opt_x) {
1170     for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1171 }
1172
1173 close XS;
1174
1175 if (%types_seen) {
1176   my $type;
1177   warn "Writing $ext$modpname/typemap\n";
1178   open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1179
1180   for $type (keys %types_seen) {
1181     my $entry = assign_typemap_entry $type;
1182     print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
1183   }
1184
1185   print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1186 #############################################################################
1187 INPUT
1188 T_OPAQUE_STRUCT
1189         if (sv_derived_from($arg, \"${ntype}\")) {
1190             STRLEN len;
1191             char  *s = SvPV((SV*)SvRV($arg), len);
1192
1193             if (len != sizeof($var))
1194                 croak(\"Size %d of packed data != expected %d\",
1195                         len, sizeof($var));
1196             $var = *($type *)s;
1197         }
1198         else
1199             croak(\"$var is not of type ${ntype}\")
1200 #############################################################################
1201 OUTPUT
1202 T_OPAQUE_STRUCT
1203         sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1204 EOP
1205
1206   close TM or die "Cannot close typemap file for write: $!";
1207 }
1208
1209 } # if( ! $opt_X )
1210
1211 warn "Writing $ext$modpname/Makefile.PL\n";
1212 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
1213
1214 print PL <<'END';
1215 use ExtUtils::MakeMaker;
1216 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
1217 # the contents of the Makefile that is written.
1218 END
1219 print PL "WriteMakefile(\n";
1220 print PL "    'NAME'    => '$module',\n";
1221 print PL "    'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n";
1222 if( ! $opt_X ){ # print C stuff, unless XS is disabled
1223   $opt_F = '' unless defined $opt_F;
1224   print PL "    'LIBS'  => ['$extralibs'],   # e.g., '-lm' \n";
1225   print PL "    'DEFINE'        => '$opt_F',     # e.g., '-DHAVE_SOMETHING' \n";
1226   print PL "    'INC'   => '',     # e.g., '-I/usr/include/other' \n";
1227 }
1228 print PL ");\n";
1229 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
1230
1231 warn "Writing $ext$modpname/test.pl\n";
1232 open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
1233 print EX <<'_END_';
1234 # Before `make install' is performed this script should be runnable with
1235 # `make test'. After `make install' it should work as `perl test.pl'
1236
1237 ######################### We start with some black magic to print on failure.
1238
1239 # Change 1..1 below to 1..last_test_to_print .
1240 # (It may become useful if the test is moved to ./t subdirectory.)
1241
1242 BEGIN { $| = 1; print "1..1\n"; }
1243 END {print "not ok 1\n" unless $loaded;}
1244 _END_
1245 print EX <<_END_;
1246 use $module;
1247 _END_
1248 print EX <<'_END_';
1249 $loaded = 1;
1250 print "ok 1\n";
1251
1252 ######################### End of black magic.
1253
1254 # Insert your test code below (better if it prints "ok 13"
1255 # (correspondingly "not ok 13") depending on the success of chunk 13
1256 # of the test code):
1257
1258 _END_
1259 close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
1260
1261 unless ($opt_C) {
1262   warn "Writing $ext$modpname/Changes\n";
1263   $" = ' ';
1264   open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
1265   @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
1266   print EX <<EOP;
1267 Revision history for Perl extension $module.
1268
1269 $TEMPLATE_VERSION  @{[scalar localtime]}
1270 \t- original version; created by h2xs $H2XS_VERSION with options
1271 \t\t@ARGS
1272
1273 EOP
1274   close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
1275 }
1276
1277 warn "Writing $ext$modpname/MANIFEST\n";
1278 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
1279 @files = <*>;
1280 if (!@files) {
1281   eval {opendir(D,'.');};
1282   unless ($@) { @files = readdir(D); closedir(D); }
1283 }
1284 if (!@files) { @files = map {chomp && $_} `ls`; }
1285 if ($^O eq 'VMS') {
1286   foreach (@files) {
1287     # Clip trailing '.' for portability -- non-VMS OSs don't expect it
1288     s%\.$%%;
1289     # Fix up for case-sensitive file systems
1290     s/$modfname/$modfname/i && next;
1291     $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
1292     $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
1293   }
1294 }
1295 print MANI join("\n",@files), "\n";
1296 close MANI;
1297 !NO!SUBS!
1298
1299 close OUT or die "Can't close $file: $!";
1300 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1301 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
1302 chdir $origdir;