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