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