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 use warnings;
  39
  40 =head1 NAME
  41
  42 h2xs - convert .h C header files to Perl extensions
  43
  44 =head1 SYNOPSIS
  45
  46 B<h2xs> [B<OPTIONS> ...] [headerfile ... [extra_libraries]]
  47
  48 B<h2xs> B<-h>|B<-?>|B<--help>
  49
  50 =head1 DESCRIPTION
  51
  52 I<h2xs> builds a Perl extension from C header files.  The extension
  53 will include functions which can be used to retrieve the value of any
  54 #define statement which was in the C header files.
  55
  56 The I<module_name> will be used for the name of the extension.  If
  57 module_name is not supplied then the name of the first header file
  58 will be used, with the first character capitalized.
  59
  60 If the extension might need extra libraries, they should be included
  61 here.  The extension Makefile.PL will take care of checking whether
  62 the libraries actually exist and how they should be loaded.  The extra
  63 libraries should be specified in the form -lm -lposix, etc, just as on
  64 the cc command line.  By default, the Makefile.PL will search through
  65 the library path determined by Configure.  That path can be augmented
  66 by including arguments of the form B<-L/another/library/path> in the
  67 extra-libraries argument.
  68
  69 =head1 OPTIONS
  70
  71 =over 5
  72
  73 =item B<-A>, B<--omit-autoload>
  74
  75 Omit all autoload facilities.  This is the same as B<-c> but also
  76 removes the S<C<use AutoLoader>> statement from the .pm file.
  77
  78 =item B<-B>, B<--beta-version>
  79
  80 Use an alpha/beta style version number.  Causes version number to
  81 be "0.00_01" unless B<-v> is specified.
  82
  83 =item B<-C>, B<--omit-changes>
  84
  85 Omits creation of the F<Changes> file, and adds a HISTORY section to
  86 the POD template.
  87
  88 =item B<-F>, B<--cpp-flags>=I<addflags>
  89
  90 Additional flags to specify to C preprocessor when scanning header for
  91 function declarations.  Writes these options in the generated F<Makefile.PL>
  92 too.
  93
  94 =item B<-M>, B<--func-mask>=I<regular expression>
  95
  96 selects functions/macros to process.
  97
  98 =item B<-O>, B<--overwrite-ok>
  99
 100 Allows a pre-existing extension directory to be overwritten.
 101
 102 =item B<-P>, B<--omit-pod>
 103
 104 Omit the autogenerated stub POD section.
 105
 106 =item B<-X>, B<--omit-XS>
 107
 108 Omit the XS portion.  Used to generate templates for a module which is not
 109 XS-based.  C<-c> and C<-f> are implicitly enabled.
 110
 111 =item B<-a>, B<--gen-accessors>
 112
 113 Generate an accessor method for each element of structs and unions. The
 114 generated methods are named after the element name; will return the current
 115 value of the element if called without additional arguments; and will set
 116 the element to the supplied value (and return the new value) if called with
 117 an additional argument. Embedded structures and unions are returned as a
 118 pointer rather than the complete structure, to facilitate chained calls.
 119
 120 These methods all apply to the Ptr type for the structure; additionally
 121 two methods are constructed for the structure type itself, C<_to_ptr>
 122 which returns a Ptr type pointing to the same structure, and a C<new>
 123 method to construct and return a new structure, initialised to zeroes.
 124
 125 =item B<-b>, B<--compat-version>=I<version>
 126
 127 Generates a .pm file which is backwards compatible with the specified
 128 perl version.
 129
 130 For versions < 5.6.0, the changes are.
 131     - no use of 'our' (uses 'use vars' instead)
 132     - no 'use warnings'
 133
 134 Specifying a compatibility version higher than the version of perl you
 135 are using to run h2xs will have no effect.  If unspecified h2xs will default
 136 to compatibility with the version of perl you are using to run h2xs.
 137
 138 =item B<-c>, B<--omit-constant>
 139
 140 Omit C<constant()> from the .xs file and corresponding specialised
 141 C<AUTOLOAD> from the .pm file.
 142
 143 =item B<-d>, B<--debugging>
 144
 145 Turn on debugging messages.
 146
 147 =item B<-e>, B<--omit-enums>=[I<regular expression>]
 148
 149 If I<regular expression> is not given, skip all constants that are defined in
 150 a C enumeration. Otherwise skip only those constants that are defined in an
 151 enum whose name matches I<regular expression>.
 152
 153 Since I<regular expression> is optional, make sure that this switch is followed
 154 by at least one other switch if you omit I<regular expression> and have some
 155 pending arguments such as header-file names. This is ok:
 156
 157     h2xs -e -n Module::Foo foo.h
 158
 159 This is not ok:
 160
 161     h2xs -n Module::Foo -e foo.h
 162
 163 In the latter, foo.h is taken as I<regular expression>.
 164
 165 =item B<-f>, B<--force>
 166
 167 Allows an extension to be created for a header even if that header is
 168 not found in standard include directories.
 169
 170 =item B<-g>, B<--global>
 171
 172 Include code for safely storing static data in the .xs file.
 173 Extensions that do no make use of static data can ignore this option.
 174
 175 =item B<-h>, B<-?>, B<--help>
 176
 177 Print the usage, help and version for this h2xs and exit.
 178
 179 =item B<-k>, B<--omit-const-func>
 180
 181 For function arguments declared as C<const>, omit the const attribute in the
 182 generated XS code.
 183
 184 =item B<-m>, B<--gen-tied-var>
 185
 186 B<Experimental>: for each variable declared in the header file(s), declare
 187 a perl variable of the same name magically tied to the C variable.
 188
 189 =item B<-n>, B<--name>=I<module_name>
 190
 191 Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
 192
 193 =item B<-o>, B<--opaque-re>=I<regular expression>
 194
 195 Use "opaque" data type for the C types matched by the regular
 196 expression, even if these types are C<typedef>-equivalent to types
 197 from typemaps.  Should not be used without B<-x>.
 198
 199 This may be useful since, say, types which are C<typedef>-equivalent
 200 to integers may represent OS-related handles, and one may want to work
 201 with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
 202 Use C<-o .> if you want to handle all the C<typedef>ed types as opaque
 203 types.
 204
 205 The type-to-match is whitewashed (except for commas, which have no
 206 whitespace before them, and multiple C<*> which have no whitespace
 207 between them).
 208
 209 =item B<-p>, B<--remove-prefix>=I<prefix>
 210
 211 Specify a prefix which should be removed from the Perl function names,
 212 e.g., S<-p sec_rgy_> This sets up the XS B<PREFIX> keyword and removes
 213 the prefix from functions that are autoloaded via the C<constant()>
 214 mechanism.
 215
 216 =item B<-s>, B<--const-subs>=I<sub1,sub2>
 217
 218 Create a perl subroutine for the specified macros rather than autoload
 219 with the constant() subroutine.  These macros are assumed to have a
 220 return type of B<char *>, e.g.,
 221 S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
 222
 223 =item B<-t>, B<--default-type>=I<type>
 224
 225 Specify the internal type that the constant() mechanism uses for macros.
 226 The default is IV (signed integer).  Currently all macros found during the
 227 header scanning process will be assumed to have this type.  Future versions
 228 of C<h2xs> may gain the ability to make educated guesses.
 229
 230 =item B<--use-new-tests>
 231
 232 When B<--compat-version> (B<-b>) is present the generated tests will use
 233 C<Test::More> rather than C<Test> which is the default for versions before
 234 5.7.2 .   C<Test::More> will be added to PREREQ_PM in the generated
 235 C<Makefile.PL>.
 236
 237 =item B<--use-old-tests>
 238
 239 Will force the generation of test code that uses the older C<Test> module.
 240
 241 =item B<--skip-exporter>
 242
 243 Do not use C<Exporter> and/or export any symbol.
 244
 245 =item B<--skip-ppport>
 246
 247 Do not use C<Devel::PPPort>: no portability to older version.
 248
 249 =item B<--skip-autoloader>
 250
 251 Do not use the module C<AutoLoader>; but keep the constant() function
 252 and C<sub AUTOLOAD> for constants.
 253
 254 =item B<--skip-strict>
 255
 256 Do not use the pragma C<strict>.
 257
 258 =item B<--skip-warnings>
 259
 260 Do not use the pragma C<warnings>.
 261
 262 =item B<-v>, B<--version>=I<version>
 263
 264 Specify a version number for this extension.  This version number is added
 265 to the templates.  The default is 0.01, or 0.00_01 if C<-B> is specified.
 266 The version specified should be numeric.
 267
 268 =item B<-x>, B<--autogen-xsubs>
 269
 270 Automatically generate XSUBs basing on function declarations in the
 271 header file.  The package C<C::Scan> should be installed. If this
 272 option is specified, the name of the header file may look like
 273 C<NAME1,NAME2>. In this case NAME1 is used instead of the specified
 274 string, but XSUBs are emitted only for the declarations included from
 275 file NAME2.
 276
 277 Note that some types of arguments/return-values for functions may
 278 result in XSUB-declarations/typemap-entries which need
 279 hand-editing. Such may be objects which cannot be converted from/to a
 280 pointer (like C<long long>), pointers to functions, or arrays.  See
 281 also the section on L<LIMITATIONS of B<-x>>.
 282
 283 =back
 284
 285 =head1 EXAMPLES
 286
 287
 288     # Default behavior, extension is Rusers
 289     h2xs rpcsvc/rusers
 290
 291     # Same, but extension is RUSERS
 292     h2xs -n RUSERS rpcsvc/rusers
 293
 294     # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
 295     h2xs rpcsvc::rusers
 296
 297     # Extension is ONC::RPC.  Still finds <rpcsvc/rusers.h>
 298     h2xs -n ONC::RPC rpcsvc/rusers
 299
 300     # Without constant() or AUTOLOAD
 301     h2xs -c rpcsvc/rusers
 302
 303     # Creates templates for an extension named RPC
 304     h2xs -cfn RPC
 305
 306     # Extension is ONC::RPC.
 307     h2xs -cfn ONC::RPC
 308
 309     # Extension is Lib::Foo which works at least with Perl5.005_03.
 310     # Constants are created for all #defines and enums h2xs can find
 311     # in foo.h.
 312     h2xs -b 5.5.3 -n Lib::Foo foo.h
 313
 314     # Extension is Lib::Foo which works at least with Perl5.005_03.
 315     # Constants are created for all #defines but only for enums
 316     # whose names do not start with 'bar_'.
 317     h2xs -b 5.5.3 -e '^bar_' -n Lib::Foo foo.h
 318
 319     # Makefile.PL will look for library -lrpc in
 320     # additional directory /opt/net/lib
 321     h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
 322
 323     # Extension is DCE::rgynbase
 324     # prefix "sec_rgy_" is dropped from perl function names
 325     h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
 326
 327     # Extension is DCE::rgynbase
 328     # prefix "sec_rgy_" is dropped from perl function names
 329     # subroutines are created for sec_rgy_wildcard_name and
 330     # sec_rgy_wildcard_sid
 331     h2xs -n DCE::rgynbase -p sec_rgy_ \
 332     -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
 333
 334     # Make XS without defines in perl.h, but with function declarations
 335     # visible from perl.h. Name of the extension is perl1.
 336     # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
 337     # Extra backslashes below because the string is passed to shell.
 338     # Note that a directory with perl header files would
 339     #  be added automatically to include path.
 340     h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
 341
 342     # Same with function declaration in proto.h as visible from perl.h.
 343     h2xs -xAn perl2 perl.h,proto.h
 344
 345     # Same but select only functions which match /^av_/
 346     h2xs -M '^av_' -xAn perl2 perl.h,proto.h
 347
 348     # Same but treat SV* etc as "opaque" types
 349     h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h
 350
 351 =head2 Extension based on F<.h> and F<.c> files
 352
 353 Suppose that you have some C files implementing some functionality,
 354 and the corresponding header files.  How to create an extension which
 355 makes this functionality accessable in Perl?  The example below
 356 assumes that the header files are F<interface_simple.h> and
 357 I<interface_hairy.h>, and you want the perl module be named as
 358 C<Ext::Ension>.  If you need some preprocessor directives and/or
 359 linking with external libraries, see the flags C<-F>, C<-L> and C<-l>
 360 in L<"OPTIONS">.
 361
 362 =over
 363
 364 =item Find the directory name
 365
 366 Start with a dummy run of h2xs:
 367
 368   h2xs -Afn Ext::Ension
 369
 370 The only purpose of this step is to create the needed directories, and
 371 let you know the names of these directories.  From the output you can
 372 see that the directory for the extension is F<Ext/Ension>.
 373
 374 =item Copy C files
 375
 376 Copy your header files and C files to this directory F<Ext/Ension>.
 377
 378 =item Create the extension
 379
 380 Run h2xs, overwriting older autogenerated files:
 381
 382   h2xs -Oxan Ext::Ension interface_simple.h interface_hairy.h
 383
 384 h2xs looks for header files I<after> changing to the extension
 385 directory, so it will find your header files OK.
 386
 387 =item Archive and test
 388
 389 As usual, run
 390
 391   cd Ext/Ension
 392   perl Makefile.PL
 393   make dist
 394   make
 395   make test
 396
 397 =item Hints
 398
 399 It is important to do C<make dist> as early as possible.  This way you
 400 can easily merge(1) your changes to autogenerated files if you decide
 401 to edit your C<.h> files and rerun h2xs.
 402
 403 Do not forget to edit the documentation in the generated F<.pm> file.
 404
 405 Consider the autogenerated files as skeletons only, you may invent
 406 better interfaces than what h2xs could guess.
 407
 408 Consider this section as a guideline only, some other options of h2xs
 409 may better suit your needs.
 410
 411 =back
 412
 413 =head1 ENVIRONMENT
 414
 415 No environment variables are used.
 416
 417 =head1 AUTHOR
 418
 419 Larry Wall and others
 420
 421 =head1 SEE ALSO
 422
 423 L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
 424
 425 =head1 DIAGNOSTICS
 426
 427 The usual warnings if it cannot read or write the files involved.
 428
 429 =head1 LIMITATIONS of B<-x>
 430
 431 F<h2xs> would not distinguish whether an argument to a C function
 432 which is of the form, say, C<int *>, is an input, output, or
 433 input/output parameter.  In particular, argument declarations of the
 434 form
 435
 436     int
 437     foo(n)
 438         int *n
 439
 440 should be better rewritten as
 441
 442     int
 443     foo(n)
 444         int &n
 445
 446 if C<n> is an input parameter.
 447
 448 Additionally, F<h2xs> has no facilities to intuit that a function
 449
 450    int
 451    foo(addr,l)
 452         char *addr
 453         int   l
 454
 455 takes a pair of address and length of data at this address, so it is better
 456 to rewrite this function as
 457
 458     int
 459     foo(sv)
 460             SV *addr
 461         PREINIT:
 462             STRLEN len;
 463             char *s;
 464         CODE:
 465             s = SvPV(sv,len);
 466             RETVAL = foo(s, len);
 467         OUTPUT:
 468             RETVAL
 469
 470 or alternately
 471
 472     static int
 473     my_foo(SV *sv)
 474     {
 475         STRLEN len;
 476         char *s = SvPV(sv,len);
 477
 478         return foo(s, len);
 479     }
 480
 481     MODULE = foo        PACKAGE = foo   PREFIX = my_
 482
 483     int
 484     foo(sv)
 485         SV *sv
 486
 487 See L<perlxs> and L<perlxstut> for additional details.
 488
 489 =cut
 490
 491 # ' # Grr
 492 use strict;
 493
 494
 495 my( $H2XS_VERSION ) = ' $Revision: 1.22 $ ' =~ /\$Revision:\s+([^\s]+)/;
 496 my $TEMPLATE_VERSION = '0.01';
 497 my @ARGS = @ARGV;
 498 my $compat_version = $];
 499
 500 use Getopt::Long;
 501 use Config;
 502 use Text::Wrap;
 503 $Text::Wrap::huge = 'overflow';
 504 $Text::Wrap::columns = 80;
 505 use ExtUtils::Constant qw (WriteConstants WriteMakefileSnippet autoload);
 506 use File::Compare;
 507
 508 sub usage {
 509     warn "@_\n" if @_;
 510     die <<EOFUSAGE;
 511 h2xs [OPTIONS ... ] [headerfile [extra_libraries]]
 512 version: $H2XS_VERSION
 513 OPTIONS:
 514     -A, --omit-autoload   Omit all autoloading facilities (implies -c).
 515     -B, --beta-version    Use beta \$VERSION of 0.00_01 (ignored if -v).
 516     -C, --omit-changes    Omit creating the Changes file, add HISTORY heading
 517                           to stub POD.
 518     -F, --cpp-flags       Additional flags for C preprocessor/compile.
 519     -M, --func-mask       Mask to select C functions/macros
 520                           (default is select all).
 521     -O, --overwrite-ok    Allow overwriting of a pre-existing extension directory.
 522     -P, --omit-pod        Omit the stub POD section.
 523     -X, --omit-XS         Omit the XS portion (implies both -c and -f).
 524     -a, --gen-accessors   Generate get/set accessors for struct and union members                           (used with -x).
 525     -b, --compat-version  Specify a perl version to be backwards compatibile with
 526     -c, --omit-constant   Omit the constant() function and specialised AUTOLOAD
 527                           from the XS file.
 528     -d, --debugging       Turn on debugging messages.
 529     -e, --omit-enums      Omit constants from enums in the constant() function.
 530                           If a pattern is given, only the matching enums are
 531                           ignored.
 532     -f, --force           Force creation of the extension even if the C header
 533                           does not exist.
 534     -g, --global          Include code for safely storing static data in the .xs file.
 535     -h, -?, --help        Display this help message
 536     -k, --omit-const-func Omit 'const' attribute on function arguments
 537                           (used with -x).
 538     -m, --gen-tied-var    Generate tied variables for access to declared
 539                           variables.
 540     -n, --name            Specify a name to use for the extension (recommended).
 541     -o, --opaque-re       Regular expression for \"opaque\" types.
 542     -p, --remove-prefix   Specify a prefix which should be removed from the
 543                           Perl function names.
 544     -s, --const-subs      Create subroutines for specified macros.
 545     -t, --default-type    Default type for autoloaded constants (default is IV)
 546         --use-new-tests   Use Test::More in backward compatible modules
 547         --use-old-tests   Use the module Test rather than Test::More
 548         --skip-exporter   Do not export symbols
 549         --skip-ppport     Do not use portability layer
 550         --skip-autoloader Do not use the module C<AutoLoader>
 551         --skip-strict     Do not use the pragma C<strict>
 552         --skip-warnings   Do not use the pragma C<warnings>
 553     -v, --version         Specify a version number for this extension.
 554     -x, --autogen-xsubs   Autogenerate XSUBs using C::Scan.
 555
 556 extra_libraries
 557          are any libraries that might be needed for loading the
 558          extension, e.g. -lm would try to link in the math library.
 559 EOFUSAGE
 560 }
 561
 562 my ($opt_A,
 563     $opt_B,
 564     $opt_C,
 565     $opt_F,
 566     $opt_M,
 567     $opt_O,
 568     $opt_P,
 569     $opt_X,
 570     $opt_a,
 571     $opt_c,
 572     $opt_d,
 573     $opt_e,
 574     $opt_f,
 575     $opt_g,
 576     $opt_h,
 577     $opt_k,
 578     $opt_m,
 579     $opt_n,
 580     $opt_o,
 581     $opt_p,
 582     $opt_s,
 583     $opt_v,
 584     $opt_x,
 585     $opt_b,
 586     $opt_t,
 587     $new_test,
 588     $old_test,
 589     $skip_exporter,
 590     $skip_ppport,
 591     $skip_autoloader,
 592     $skip_strict,
 593     $skip_warnings,
 594    );
 595
 596 Getopt::Long::Configure('bundling');
 597
 598 my %options = (
 599                 'omit-autoload|A'    => \$opt_A,
 600                 'beta-version|B'     => \$opt_B,
 601                 'omit-changes|C'     => \$opt_C,
 602                 'cpp-flags|F=s'      => \$opt_F,
 603                 'func-mask|M=s'      => \$opt_M,
 604                 'overwrite_ok|O'     => \$opt_O,
 605                 'omit-pod|P'         => \$opt_P,
 606                 'omit-XS|X'          => \$opt_X,
 607                 'gen-accessors|a'    => \$opt_a,
 608                 'compat-version|b=s' => \$opt_b,
 609                 'omit-constant|c'    => \$opt_c,
 610                 'debugging|d'        => \$opt_d,
 611                 'omit-enums|e:s'     => \$opt_e,
 612                 'force|f'            => \$opt_f,
 613                 'global|g'           => \$opt_g,
 614                 'help|h|?'           => \$opt_h,
 615                 'omit-const-func|k'  => \$opt_k,
 616                 'gen-tied-var|m'     => \$opt_m,
 617                 'name|n=s'           => \$opt_n,
 618                 'opaque-re|o=s'      => \$opt_o,
 619                 'remove-prefix|p=s'  => \$opt_p,
 620                 'const-subs|s=s'     => \$opt_s,
 621                 'default-type|t=s'   => \$opt_t,
 622                 'version|v=s'        => \$opt_v,
 623                 'autogen-xsubs|x'    => \$opt_x,
 624                 'use-new-tests'      => \$new_test,
 625                 'use-old-tests'      => \$old_test,
 626                 'skip-exporter'      => \$skip_exporter,
 627                 'skip-ppport'        => \$skip_ppport,
 628                 'skip-autoloader'    => \$skip_autoloader,
 629                 'skip-warnings'      => \$skip_warnings,
 630                 'skip-strict'        => \$skip_strict,
 631               );
 632
 633 GetOptions(%options) || usage;
 634
 635 usage if $opt_h;
 636
 637 if( $opt_b ){
 638     usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m);
 639     $opt_b =~ /^\d+\.\d+\.\d+/ ||
 640     usage "You must provide the backwards compatibility version in X.Y.Z form. "
 641           .  "(i.e. 5.5.0)\n";
 642     my ($maj,$min,$sub) = split(/\./,$opt_b,3);
 643     if ($maj < 5 || ($maj == 5 && $min < 6)) {
 644         $compat_version =
 645             $sub ? sprintf("%d.%03d%02d",$maj,$min,$sub) :
 646                    sprintf("%d.%03d",    $maj,$min);
 647     } else {
 648         $compat_version =
 649             $sub ? sprintf("%d.%03d%03d",$maj,$min,$sub) :
 650                    sprintf("%d.%03d",    $maj,$min);
 651     }
 652 } else {
 653     my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d*)/;
 654     $sub ||= 0;
 655     warn sprintf <<'EOF', $maj,$min,$sub;
 656 Defaulting to backwards compatibility with perl %d.%d.%d
 657 If you intend this module to be compatible with earlier perl versions, please
 658 specify a minimum perl version with the -b option.
 659
 660 EOF
 661 }
 662
 663 if( $opt_B ){
 664     $TEMPLATE_VERSION = '0.00_01';
 665 }
 666
 667 if( $opt_v ){
 668         $TEMPLATE_VERSION = $opt_v;
 669
 670     # check if it is numeric
 671     my $temp_version = $TEMPLATE_VERSION;
 672     my $beta_version = $temp_version =~ s/(\d)_(\d\d)/$1$2/;
 673     my $notnum;
 674     {
 675         local $SIG{__WARN__} = sub { $notnum = 1 };
 676         use warnings 'numeric';
 677         $temp_version = 0+$temp_version;
 678     }
 679
 680     if ($notnum) {
 681         my $module = $opt_n || 'Your::Module';
 682         warn <<"EOF";
 683 You have specified a non-numeric version.  Unless you supply an
 684 appropriate VERSION class method, users may not be able to specify a
 685 minimum required version with C<use $module versionnum>.
 686
 687 EOF
 688     }
 689     else {
 690         $opt_B = $beta_version;
 691     }
 692 }
 693
 694 # -A implies -c.
 695 $skip_autoloader = $opt_c = 1 if $opt_A;
 696
 697 # -X implies -c and -f
 698 $opt_c = $opt_f = 1 if $opt_X;
 699
 700 $opt_t ||= 'IV';
 701
 702 my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
 703
 704 my $extralibs = '';
 705
 706 my @path_h;
 707
 708 while (my $arg = shift) {
 709     if ($arg =~ /^-l/i) {
 710         $extralibs = "$arg @ARGV";
 711         last;
 712     }
 713     push(@path_h, $arg);
 714 }
 715
 716 usage "Must supply header file or module name\n"
 717         unless (@path_h or $opt_n);
 718
 719 my $fmask;
 720 my $tmask;
 721
 722 $fmask = qr{$opt_M} if defined $opt_M;
 723 $tmask = qr{$opt_o} if defined $opt_o;
 724 my $tmask_all = $tmask && $opt_o eq '.';
 725
 726 if ($opt_x) {
 727   eval {require C::Scan; 1}
 728     or die <<EOD;
 729 C::Scan required if you use -x option.
 730 To install C::Scan, execute
 731    perl -MCPAN -e "install C::Scan"
 732 EOD
 733   unless ($tmask_all) {
 734     $C::Scan::VERSION >= 0.70
 735       or die <<EOD;
 736 C::Scan v. 0.70 or later required unless you use -o . option.
 737 You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
 738 To install C::Scan, execute
 739    perl -MCPAN -e "install C::Scan"
 740 EOD
 741   }
 742   if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) {
 743     die <<EOD;
 744 C::Scan v. 0.73 or later required to use -m or -a options.
 745 You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
 746 To install C::Scan, execute
 747    perl -MCPAN -e "install C::Scan"
 748 EOD
 749   }
 750 }
 751 elsif ($opt_o or $opt_F) {
 752   warn <<EOD if $opt_o;
 753 Option -o does not make sense without -x.
 754 EOD
 755   warn <<EOD if $opt_F and $opt_X ;
 756 Option -F does not make sense with -X.
 757 EOD
 758 }
 759
 760 my @path_h_ini = @path_h;
 761 my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
 762
 763 my $module = $opt_n;
 764
 765 if( @path_h ){
 766     use File::Spec;
 767     my @paths;
 768     my $pre_sub_tri_graphs = 1;
 769     if ($^O eq 'VMS') {  # Consider overrides of default location
 770       # XXXX This is not equivalent to what the older version did:
 771       #         it was looking at $hadsys header-file per header-file...
 772       my($hadsys) = grep s!^sys/!!i , @path_h;
 773       @paths = qw( Sys$Library VAXC$Include );
 774       push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
 775       push @paths, qw( DECC$Library_Include DECC$System_Include );
 776     }
 777     else {
 778       @paths = (File::Spec->curdir(), $Config{usrinc},
 779                 (split ' ', $Config{locincpth}), '/usr/include');
 780     }
 781     foreach my $path_h (@path_h) {
 782         $name ||= $path_h;
 783     $module ||= do {
 784       $name =~ s/\.h$//;
 785       if ( $name !~ /::/ ) {
 786         $name =~ s#^.*/##;
 787         $name = "\u$name";
 788       }
 789       $name;
 790     };
 791
 792     if( $path_h =~ s#::#/#g && $opt_n ){
 793         warn "Nesting of headerfile ignored with -n\n";
 794     }
 795     $path_h .= ".h" unless $path_h =~ /\.h$/;
 796     my $fullpath = $path_h;
 797     $path_h =~ s/,.*$// if $opt_x;
 798     $fullpath{$path_h} = $fullpath;
 799
 800     # Minor trickery: we can't chdir() before we processed the headers
 801     # (so know the name of the extension), but the header may be in the
 802     # extension directory...
 803     my $tmp_path_h = $path_h;
 804     my $rel_path_h = $path_h;
 805     my @dirs = @paths;
 806     if (not -f $path_h) {
 807       my $found;
 808       for my $dir (@paths) {
 809         $found++, last
 810           if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
 811       }
 812       if ($found) {
 813         $rel_path_h = $path_h;
 814         $fullpath{$path_h} = $fullpath;
 815       } else {
 816         (my $epath = $module) =~ s,::,/,g;
 817         $epath = File::Spec->catdir('ext', $epath) if -d 'ext';
 818         $rel_path_h = File::Spec->catfile($epath, $tmp_path_h);
 819         $path_h = $tmp_path_h;  # Used during -x
 820         push @dirs, $epath;
 821       }
 822     }
 823
 824     if (!$opt_c) {
 825       die "Can't find $tmp_path_h in @dirs\n"
 826         if ( ! $opt_f && ! -f "$rel_path_h" );
 827       # Scan the header file (we should deal with nested header files)
 828       # Record the names of simple #define constants into const_names
 829             # Function prototypes are processed below.
 830       open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n";
 831     defines:
 832       while (<CH>) {
 833         if ($pre_sub_tri_graphs) {
 834             # Preprocess all tri-graphs
 835             # including things stuck in quoted string constants.
 836             s/\?\?=/#/g;                         # | ??=|  #|
 837             s/\?\?\!/|/g;                        # | ??!|  ||
 838             s/\?\?'/^/g;                         # | ??'|  ^|
 839             s/\?\?\(/[/g;                        # | ??(|  [|
 840             s/\?\?\)/]/g;                        # | ??)|  ]|
 841             s/\?\?\-/~/g;                        # | ??-|  ~|
 842             s/\?\?\//\\/g;                       # | ??/|  \|
 843             s/\?\?</{/g;                         # | ??<|  {|
 844             s/\?\?>/}/g;                         # | ??>|  }|
 845         }
 846         if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) {
 847             my $def = $1;
 848             my $rest = $2;
 849             $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
 850             $rest =~ s/^\s+//;
 851             $rest =~ s/\s+$//;
 852             # Cannot do: (-1) and ((LHANDLE)3) are OK:
 853             #print("Skip non-wordy $def => $rest\n"),
 854             #  next defines if $rest =~ /[^\w\$]/;
 855             if ($rest =~ /"/) {
 856               print("Skip stringy $def => $rest\n") if $opt_d;
 857               next defines;
 858             }
 859             print "Matched $_ ($def)\n" if $opt_d;
 860             $seen_define{$def} = $rest;
 861             $_ = $def;
 862             next if /^_.*_h_*$/i; # special case, but for what?
 863             if (defined $opt_p) {
 864               if (!/^$opt_p(\d)/) {
 865                 ++$prefix{$_} if s/^$opt_p//;
 866               }
 867               else {
 868                 warn "can't remove $opt_p prefix from '$_'!\n";
 869               }
 870             }
 871             $prefixless{$def} = $_;
 872             if (!$fmask or /$fmask/) {
 873                 print "... Passes mask of -M.\n" if $opt_d and $fmask;
 874                 $const_names{$_}++;
 875             }
 876           }
 877       }
 878       if (defined $opt_e and !$opt_e) {
 879         close(CH);
 880       }
 881       else {
 882         use Fcntl qw/SEEK_SET/;
 883         seek CH, 0, SEEK_SET;
 884         my $src = do { local $/; <CH> };
 885         close CH;
 886         no warnings 'uninitialized';
 887
 888         # Remove C and C++ comments
 889         $src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs;
 890
 891         while ($src =~ /(\benum\s*([\w_]*)\s*\{\s([\s\w=,]+)\})/gsc) {
 892             my ($enum_name, $enum_body) =
 893                 $1 =~ /enum\s*([\w_]*)\s*\{\s([\s\w=,]+)\}/gs;
 894             # skip enums matching $opt_e
 895             next if $opt_e && $enum_name =~ /$opt_e/;
 896             my $val = 0;
 897             for my $item (split /,/, $enum_body) {
 898                 my ($key, $declared_val) = $item =~ /(\w*)\s*=\s*(.*)/;
 899                 $val = length($declared_val) ? $declared_val : 1 + $val;
 900                 $seen_define{$key} = $declared_val;
 901                 $const_names{$key}++;
 902             }
 903         } # while (...)
 904       } # if (!defined $opt_e or $opt_e)
 905     }
 906     }
 907 }
 908
 909 # Save current directory so that C::Scan can use it
 910 my $cwd = File::Spec->rel2abs( File::Spec->curdir );
 911
 912 my ($ext, $nested, @modparts, $modfname, $modpname);
 913 # As Ilya suggested, use a name that contains - and then it can't clash with
 914 # the names of any packages. A directory 'fallback' will clash with any
 915 # new pragmata down the fallback:: tree, but that seems unlikely.
 916 my $constscfname = 'const-c.inc';
 917 my $constsxsfname = 'const-xs.inc';
 918 my $fallbackdirname = 'fallback';
 919
 920 $ext = chdir 'ext' ? 'ext/' : '';
 921
 922 if( $module =~ /::/ ){
 923         $nested = 1;
 924         @modparts = split(/::/,$module);
 925         $modfname = $modparts[-1];
 926         $modpname = join('/',@modparts);
 927 }
 928 else {
 929         $nested = 0;
 930         @modparts = ();
 931         $modfname = $modpname = $module;
 932 }
 933
 934
 935 if ($opt_O) {
 936         warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
 937 }
 938 else {
 939         die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
 940 }
 941 if( $nested ){
 942         my $modpath = "";
 943         foreach (@modparts){
 944                 -d "$modpath$_" || mkdir("$modpath$_", 0777);
 945                 $modpath .= "$_/";
 946         }
 947 }
 948 -d "$modpname"   || mkdir($modpname, 0777);
 949 chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
 950
 951 my %types_seen;
 952 my %std_types;
 953 my $fdecls = [];
 954 my $fdecls_parsed = [];
 955 my $typedef_rex;
 956 my %typedefs_pre;
 957 my %known_fnames;
 958 my %structs;
 959
 960 my @fnames;
 961 my @fnames_no_prefix;
 962 my %vdecl_hash;
 963 my @vdecls;
 964
 965 if( ! $opt_X ){  # use XS, unless it was disabled
 966   unless ($skip_ppport) {
 967     require Devel::PPPort;
 968     warn "Writing $ext$modpname/ppport.h\n";
 969     Devel::PPPort::WriteFile('ppport.h')
 970         || die "Can't create $ext$modpname/ppport.h: $!\n";
 971   }
 972   open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
 973   if ($opt_x) {
 974     warn "Scanning typemaps...\n";
 975     get_typemap();
 976     my @td;
 977     my @good_td;
 978     my $addflags = $opt_F || '';
 979
 980     foreach my $filename (@path_h) {
 981       my $c;
 982       my $filter;
 983
 984       if ($fullpath{$filename} =~ /,/) {
 985         $filename = $`;
 986         $filter = $';
 987       }
 988       warn "Scanning $filename for functions...\n";
 989       my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X);
 990       $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
 991         'add_cppflags' => $addflags, 'c_styles' => \@styles;
 992       $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]);
 993
 994       push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
 995       push(@$fdecls, @{$c->get('fdecls')});
 996
 997       push @td, @{$c->get('typedefs_maybe')};
 998       if ($opt_a) {
 999         my $structs = $c->get('typedef_structs');
1000         @structs{keys %$structs} = values %$structs;
1001       }
1002
1003       if ($opt_m) {
1004         %vdecl_hash = %{ $c->get('vdecl_hash') };
1005         @vdecls = sort keys %vdecl_hash;
1006         for (local $_ = 0; $_ < @vdecls; ++$_) {
1007           my $var = $vdecls[$_];
1008           my($type, $post) = @{ $vdecl_hash{$var} };
1009           if (defined $post) {
1010             warn "Can't handle variable '$type $var $post', skipping.\n";
1011             splice @vdecls, $_, 1;
1012             redo;
1013           }
1014           $type = normalize_type($type);
1015           $vdecl_hash{$var} = $type;
1016         }
1017       }
1018
1019       unless ($tmask_all) {
1020         warn "Scanning $filename for typedefs...\n";
1021         my $td = $c->get('typedef_hash');
1022         # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
1023         my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
1024         push @good_td, @f_good_td;
1025         @typedefs_pre{@f_good_td}  = map $_->[0], @$td{@f_good_td};
1026       }
1027     }
1028     { local $" = '|';
1029       $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
1030     }
1031     %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
1032     if ($fmask) {
1033       my @good;
1034       for my $i (0..$#$fdecls_parsed) {
1035         next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
1036         push @good, $i;
1037         print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
1038           if $opt_d;
1039       }
1040       $fdecls = [@$fdecls[@good]];
1041       $fdecls_parsed = [@$fdecls_parsed[@good]];
1042     }
1043     @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
1044     # Sort declarations:
1045     {
1046       my %h = map( ($_->[1], $_), @$fdecls_parsed);
1047       $fdecls_parsed = [ @h{@fnames} ];
1048     }
1049     @fnames_no_prefix = @fnames;
1050     @fnames_no_prefix
1051       = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix
1052          if defined $opt_p;
1053     # Remove macros which expand to typedefs
1054     print "Typedefs are @td.\n" if $opt_d;
1055     my %td = map {($_, $_)} @td;
1056     # Add some other possible but meaningless values for macros
1057     for my $k (qw(char double float int long short unsigned signed void)) {
1058       $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
1059     }
1060     # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
1061     my $n = 0;
1062     my %bad_macs;
1063     while (keys %td > $n) {
1064       $n = keys %td;
1065       my ($k, $v);
1066       while (($k, $v) = each %seen_define) {
1067         # print("found '$k'=>'$v'\n"),
1068         $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
1069       }
1070     }
1071     # Now %bad_macs contains names of bad macros
1072     for my $k (keys %bad_macs) {
1073       delete $const_names{$prefixless{$k}};
1074       print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
1075     }
1076   }
1077 }
1078 my @const_names = sort keys %const_names;
1079
1080 open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
1081
1082 $" = "\n\t";
1083 warn "Writing $ext$modpname/$modfname.pm\n";
1084
1085 print PM <<"END";
1086 package $module;
1087
1088 use $compat_version;
1089 END
1090
1091 print PM <<"END" unless $skip_strict;
1092 use strict;
1093 END
1094
1095 print PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006;
1096
1097 unless( $opt_X || $opt_c || $opt_A ){
1098         # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
1099         # will want Carp.
1100         print PM <<'END';
1101 use Carp;
1102 END
1103 }
1104
1105 print PM <<'END' unless $skip_exporter;
1106
1107 require Exporter;
1108 END
1109
1110 my $use_Dyna = (not $opt_X and $compat_version < 5.006);
1111 print PM <<"END" if $use_Dyna;  # use DynaLoader, unless XS was disabled
1112 require DynaLoader;
1113 END
1114
1115
1116 # Are we using AutoLoader or not?
1117 unless ($skip_autoloader) { # no autoloader whatsoever.
1118         unless ($opt_c) { # we're doing the AUTOLOAD
1119                 print PM "use AutoLoader;\n";
1120         }
1121         else {
1122                 print PM "use AutoLoader qw(AUTOLOAD);\n"
1123         }
1124 }
1125
1126 if ( $compat_version < 5.006 ) {
1127     my $vars = '$VERSION @ISA';
1128     $vars .= ' @EXPORT @EXPORT_OK %EXPORT_TAGS' unless $skip_exporter;
1129     $vars .= ' $AUTOLOAD' unless $opt_X || $opt_c || $opt_A;
1130     $vars .= ' $XS_VERSION' if $opt_B && !$opt_X;
1131     print PM "use vars qw($vars);";
1132 }
1133
1134 # Determine @ISA.
1135 my @modISA;
1136 push @modISA, 'Exporter'        unless $skip_exporter;
1137 push @modISA, 'DynaLoader'      if $use_Dyna;  # no XS
1138 my $myISA = "our \@ISA = qw(@modISA);";
1139 $myISA =~ s/^our // if $compat_version < 5.006;
1140
1141 print PM "\n$myISA\n\n";
1142
1143 my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
1144
1145 my $tmp='';
1146 $tmp .= <<"END" unless $skip_exporter;
1147 # Items to export into callers namespace by default. Note: do not export
1148 # names by default without a very good reason. Use EXPORT_OK instead.
1149 # Do not simply export all your public functions/methods/constants.
1150
1151 # This allows declaration       use $module ':all';
1152 # If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
1153 # will save memory.
1154 our %EXPORT_TAGS = ( 'all' => [ qw(
1155         @exported_names
1156 ) ] );
1157
1158 our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
1159
1160 our \@EXPORT = qw(
1161         @const_names
1162 );
1163
1164 END
1165
1166 $tmp .= "our \$VERSION = '$TEMPLATE_VERSION';\n";
1167 if ($opt_B) {
1168     $tmp .= "our \$XS_VERSION = \$VERSION;\n" unless $opt_X;
1169     $tmp .= "\$VERSION = eval \$VERSION;  # see L<perlmodstyle>\n";
1170 }
1171 $tmp .= "\n";
1172
1173 $tmp =~ s/^our //mg if $compat_version < 5.006;
1174 print PM $tmp;
1175
1176 if (@vdecls) {
1177     printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
1178 }
1179
1180
1181 print PM autoload ($module, $compat_version) unless $opt_c or $opt_X;
1182
1183 if( ! $opt_X ){ # print bootstrap, unless XS is disabled
1184   if ($use_Dyna) {
1185         $tmp = <<"END";
1186 bootstrap $module \$VERSION;
1187 END
1188   } else {
1189         $tmp = <<"END";
1190 require XSLoader;
1191 XSLoader::load('$module', \$VERSION);
1192 END
1193   }
1194   $tmp =~ s:\$VERSION:\$XS_VERSION:g if $opt_B;
1195   print PM $tmp;
1196 }
1197
1198 # tying the variables can happen only after bootstrap
1199 if (@vdecls) {
1200     printf PM <<END;
1201 {
1202 @{[ join "\n", map "    _tievar_$_(\$$_);", @vdecls ]}
1203 }
1204
1205 END
1206 }
1207
1208 my $after;
1209 if( $opt_P ){ # if POD is disabled
1210         $after = '__END__';
1211 }
1212 else {
1213         $after = '=cut';
1214 }
1215
1216 print PM <<"END";
1217
1218 # Preloaded methods go here.
1219 END
1220
1221 print PM <<"END" unless $opt_A;
1222
1223 # Autoload methods go after $after, and are processed by the autosplit program.
1224 END
1225
1226 print PM <<"END";
1227
1228 1;
1229 __END__
1230 END
1231
1232 my ($email,$author);
1233
1234 eval {
1235        my $username;
1236        ($username,$author) = (getpwuid($>))[0,6];
1237        if (defined $username && defined $author) {
1238            $author =~ s/,.*$//; # in case of sub fields
1239            my $domain = $Config{'mydomain'};
1240            $domain =~ s/^\.//;
1241            $email = "$username\@$domain";
1242        }
1243      };
1244
1245 $author ||= "A. U. Thor";
1246 $email  ||= 'a.u.thor@a.galaxy.far.far.away';
1247
1248 my $revhist = '';
1249 $revhist = <<EOT if $opt_C;
1250 #
1251 #=head1 HISTORY
1252 #
1253 #=over 8
1254 #
1255 #=item $TEMPLATE_VERSION
1256 #
1257 #Original version; created by h2xs $H2XS_VERSION with options
1258 #
1259 #  @ARGS
1260 #
1261 #=back
1262 #
1263 EOT
1264
1265 my $exp_doc = $skip_exporter ? '' : <<EOD;
1266 #
1267 #=head2 EXPORT
1268 #
1269 #None by default.
1270 #
1271 EOD
1272
1273 if (@const_names and not $opt_P) {
1274   $exp_doc .= <<EOD unless $skip_exporter;
1275 #=head2 Exportable constants
1276 #
1277 #  @{[join "\n  ", @const_names]}
1278 #
1279 EOD
1280 }
1281
1282 if (defined $fdecls and @$fdecls and not $opt_P) {
1283   $exp_doc .= <<EOD unless $skip_exporter;
1284 #=head2 Exportable functions
1285 #
1286 EOD
1287
1288 #  $exp_doc .= <<EOD if $opt_p;
1289 #When accessing these functions from Perl, prefix C<$opt_p> should be removed.
1290 #
1291 #EOD
1292   $exp_doc .= <<EOD unless $skip_exporter;
1293 #  @{[join "\n  ", @known_fnames{@fnames}]}
1294 #
1295 EOD
1296 }
1297
1298 my $meth_doc = '';
1299
1300 if ($opt_x && $opt_a) {
1301   my($name, $struct);
1302   $meth_doc .= accessor_docs($name, $struct)
1303     while ($name, $struct) = each %structs;
1304 }
1305
1306 my $pod = <<"END" unless $opt_P;
1307 ## Below is stub documentation for your module. You'd better edit it!
1308 #
1309 #=head1 NAME
1310 #
1311 #$module - Perl extension for blah blah blah
1312 #
1313 #=head1 SYNOPSIS
1314 #
1315 #  use $module;
1316 #  blah blah blah
1317 #
1318 #=head1 DESCRIPTION
1319 #
1320 #Stub documentation for $module, created by h2xs. It looks like the
1321 #author of the extension was negligent enough to leave the stub
1322 #unedited.
1323 #
1324 #Blah blah blah.
1325 $exp_doc$meth_doc$revhist
1326 #
1327 #=head1 SEE ALSO
1328 #
1329 #Mention other useful documentation such as the documentation of
1330 #related modules or operating system documentation (such as man pages
1331 #in UNIX), or any relevant external documentation such as RFCs or
1332 #standards.
1333 #
1334 #If you have a mailing list set up for your module, mention it here.
1335 #
1336 #If you have a web site set up for your module, mention it here.
1337 #
1338 #=head1 AUTHOR
1339 #
1340 #$author, E<lt>${email}E<gt>
1341 #
1342 #=head1 COPYRIGHT AND LICENSE
1343 #
1344 #Copyright ${\(1900 + (localtime) [5])} by $author
1345 #
1346 #This library is free software; you can redistribute it and/or modify
1347 #it under the same terms as Perl itself.
1348 #
1349 #=cut
1350 END
1351
1352 $pod =~ s/^\#//gm unless $opt_P;
1353 print PM $pod unless $opt_P;
1354
1355 close PM;
1356
1357
1358 if( ! $opt_X ){ # print XS, unless it is disabled
1359 warn "Writing $ext$modpname/$modfname.xs\n";
1360
1361 print XS <<"END";
1362 #include "EXTERN.h"
1363 #include "perl.h"
1364 #include "XSUB.h"
1365
1366 END
1367
1368 print XS <<"END" unless $skip_ppport;
1369 #include "ppport.h"
1370
1371 END
1372
1373 if( @path_h ){
1374     foreach my $path_h (@path_h_ini) {
1375         my($h) = $path_h;
1376         $h =~ s#^/usr/include/##;
1377         if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
1378         print XS qq{#include <$h>\n};
1379     }
1380     print XS "\n";
1381 }
1382
1383 print XS <<"END" if $opt_g;
1384
1385 /* Global Data */
1386
1387 #define MY_CXT_KEY "${module}::_guts" XS_VERSION
1388
1389 typedef struct {
1390     /* Put Global Data in here */
1391     int dummy;          /* you can access this elsewhere as MY_CXT.dummy */
1392 } my_cxt_t;
1393
1394 START_MY_CXT
1395
1396 END
1397
1398 my %pointer_typedefs;
1399 my %struct_typedefs;
1400
1401 sub td_is_pointer {
1402   my $type = shift;
1403   my $out = $pointer_typedefs{$type};
1404   return $out if defined $out;
1405   my $otype = $type;
1406   $out = ($type =~ /\*$/);
1407   # This converts only the guys which do not have trailing part in the typedef
1408   if (not $out
1409       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1410     $type = normalize_type($type);
1411     print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1412       if $opt_d;
1413     $out = td_is_pointer($type);
1414   }
1415   return ($pointer_typedefs{$otype} = $out);
1416 }
1417
1418 sub td_is_struct {
1419   my $type = shift;
1420   my $out = $struct_typedefs{$type};
1421   return $out if defined $out;
1422   my $otype = $type;
1423   $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
1424   # This converts only the guys which do not have trailing part in the typedef
1425   if (not $out
1426       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1427     $type = normalize_type($type);
1428     print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
1429       if $opt_d;
1430     $out = td_is_struct($type);
1431   }
1432   return ($struct_typedefs{$otype} = $out);
1433 }
1434
1435 print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1436
1437 if( ! $opt_c ) {
1438   # We write the "sample" files used when this module is built by perl without
1439   # ExtUtils::Constant.
1440   # h2xs will later check that these are the same as those generated by the
1441   # code embedded into Makefile.PL
1442   unless (-d $fallbackdirname) {
1443     mkdir "$fallbackdirname" or die "Cannot mkdir $fallbackdirname: $!\n";
1444   }
1445   warn "Writing $ext$modpname/$fallbackdirname/$constscfname\n";
1446   warn "Writing $ext$modpname/$fallbackdirname/$constsxsfname\n";
1447   my $cfallback = File::Spec->catfile($fallbackdirname, $constscfname);
1448   my $xsfallback = File::Spec->catfile($fallbackdirname, $constsxsfname);
1449   WriteConstants ( C_FILE =>       $cfallback,
1450                    XS_FILE =>      $xsfallback,
1451                    DEFAULT_TYPE => $opt_t,
1452                    NAME =>         $module,
1453                    NAMES =>        \@const_names,
1454                  );
1455   print XS "#include \"$constscfname\"\n";
1456 }
1457
1458
1459 my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
1460
1461 # Now switch from C to XS by issuing the first MODULE declaration:
1462 print XS <<"END";
1463
1464 MODULE = $module                PACKAGE = $module               $prefix
1465
1466 END
1467
1468 # If a constant() function was #included then output a corresponding
1469 # XS declaration:
1470 print XS "INCLUDE: $constsxsfname\n" unless $opt_c;
1471
1472 print XS <<"END" if $opt_g;
1473
1474 BOOT:
1475 {
1476     MY_CXT_INIT;
1477     /* If any of the fields in the my_cxt_t struct need
1478        to be initialised, do it here.
1479      */
1480 }
1481
1482 END
1483
1484 foreach (sort keys %const_xsub) {
1485     print XS <<"END";
1486 char *
1487 $_()
1488
1489     CODE:
1490 #ifdef $_
1491         RETVAL = $_;
1492 #else
1493         croak("Your vendor has not defined the $module macro $_");
1494 #endif
1495
1496     OUTPUT:
1497         RETVAL
1498
1499 END
1500 }
1501
1502 my %seen_decl;
1503 my %typemap;
1504
1505 sub print_decl {
1506   my $fh = shift;
1507   my $decl = shift;
1508   my ($type, $name, $args) = @$decl;
1509   return if $seen_decl{$name}++; # Need to do the same for docs as well?
1510
1511   my @argnames = map {$_->[1]} @$args;
1512   my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
1513   if ($opt_k) {
1514     s/^\s*const\b\s*// for @argtypes;
1515   }
1516   my @argarrays = map { $_->[4] || '' } @$args;
1517   my $numargs = @$args;
1518   if ($numargs and $argtypes[-1] eq '...') {
1519     $numargs--;
1520     $argnames[-1] = '...';
1521   }
1522   local $" = ', ';
1523   $type = normalize_type($type, 1);
1524
1525   print $fh <<"EOP";
1526
1527 $type
1528 $name(@argnames)
1529 EOP
1530
1531   for my $arg (0 .. $numargs - 1) {
1532     print $fh <<"EOP";
1533         $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
1534 EOP
1535   }
1536 }
1537
1538 sub print_tievar_subs {
1539   my($fh, $name, $type) = @_;
1540   print $fh <<END;
1541 I32
1542 _get_$name(IV index, SV *sv) {
1543     dSP;
1544     PUSHMARK(SP);
1545     XPUSHs(sv);
1546     PUTBACK;
1547     (void)call_pv("$module\::_get_$name", G_DISCARD);
1548     return (I32)0;
1549 }
1550
1551 I32
1552 _set_$name(IV index, SV *sv) {
1553     dSP;
1554     PUSHMARK(SP);
1555     XPUSHs(sv);
1556     PUTBACK;
1557     (void)call_pv("$module\::_set_$name", G_DISCARD);
1558     return (I32)0;
1559 }
1560
1561 END
1562 }
1563
1564 sub print_tievar_xsubs {
1565   my($fh, $name, $type) = @_;
1566   print $fh <<END;
1567 void
1568 _tievar_$name(sv)
1569         SV* sv
1570     PREINIT:
1571         struct ufuncs uf;
1572     CODE:
1573         uf.uf_val = &_get_$name;
1574         uf.uf_set = &_set_$name;
1575         uf.uf_index = (IV)&_get_$name;
1576         sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1577
1578 void
1579 _get_$name(THIS)
1580         $type THIS = NO_INIT
1581     CODE:
1582         THIS = $name;
1583     OUTPUT:
1584         SETMAGIC: DISABLE
1585         THIS
1586
1587 void
1588 _set_$name(THIS)
1589         $type THIS
1590     CODE:
1591         $name = THIS;
1592
1593 END
1594 }
1595
1596 sub print_accessors {
1597   my($fh, $name, $struct) = @_;
1598   return unless defined $struct && $name !~ /\s|_ANON/;
1599   $name = normalize_type($name);
1600   my $ptrname = normalize_type("$name *");
1601   print $fh <<"EOF";
1602
1603 MODULE = $module                PACKAGE = ${name}               $prefix
1604
1605 $name *
1606 _to_ptr(THIS)
1607         $name THIS = NO_INIT
1608     PROTOTYPE: \$
1609     CODE:
1610         if (sv_derived_from(ST(0), "$name")) {
1611             STRLEN len;
1612             char *s = SvPV((SV*)SvRV(ST(0)), len);
1613             if (len != sizeof(THIS))
1614                 croak("Size \%d of packed data != expected \%d",
1615                         len, sizeof(THIS));
1616             RETVAL = ($name *)s;
1617         }
1618         else
1619             croak("THIS is not of type $name");
1620     OUTPUT:
1621         RETVAL
1622
1623 $name
1624 new(CLASS)
1625         char *CLASS = NO_INIT
1626     PROTOTYPE: \$
1627     CODE:
1628         Zero((void*)&RETVAL, sizeof(RETVAL), char);
1629     OUTPUT:
1630         RETVAL
1631
1632 MODULE = $module                PACKAGE = ${name}Ptr            $prefix
1633
1634 EOF
1635   my @items = @$struct;
1636   while (@items) {
1637     my $item = shift @items;
1638     if ($item->[0] =~ /_ANON/) {
1639       if (defined $item->[2]) {
1640         push @items, map [
1641           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1642         ], @{ $structs{$item->[0]} };
1643       } else {
1644         push @items, @{ $structs{$item->[0]} };
1645       }
1646     } else {
1647       my $type = normalize_type($item->[0]);
1648       my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
1649       print $fh <<"EOF";
1650 $ttype
1651 $item->[2](THIS, __value = NO_INIT)
1652         $ptrname THIS
1653         $type __value
1654     PROTOTYPE: \$;\$
1655     CODE:
1656         if (items > 1)
1657             THIS->$item->[-1] = __value;
1658         RETVAL = @{[
1659             $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1660         ]};
1661     OUTPUT:
1662         RETVAL
1663
1664 EOF
1665     }
1666   }
1667 }
1668
1669 sub accessor_docs {
1670   my($name, $struct) = @_;
1671   return unless defined $struct && $name !~ /\s|_ANON/;
1672   $name = normalize_type($name);
1673   my $ptrname = $name . 'Ptr';
1674   my @items = @$struct;
1675   my @list;
1676   while (@items) {
1677     my $item = shift @items;
1678     if ($item->[0] =~ /_ANON/) {
1679       if (defined $item->[2]) {
1680         push @items, map [
1681           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1682         ], @{ $structs{$item->[0]} };
1683       } else {
1684         push @items, @{ $structs{$item->[0]} };
1685       }
1686     } else {
1687       push @list, $item->[2];
1688     }
1689   }
1690   my $methods = (join '(...)>, C<', @list) . '(...)';
1691
1692   my $pod = <<"EOF";
1693 #
1694 #=head2 Object and class methods for C<$name>/C<$ptrname>
1695 #
1696 #The principal Perl representation of a C object of type C<$name> is an
1697 #object of class C<$ptrname> which is a reference to an integer
1698 #representation of a C pointer.  To create such an object, one may use
1699 #a combination
1700 #
1701 #  my \$buffer = $name->new();
1702 #  my \$obj = \$buffer->_to_ptr();
1703 #
1704 #This exersizes the following two methods, and an additional class
1705 #C<$name>, the internal representation of which is a reference to a
1706 #packed string with the C structure.  Keep in mind that \$buffer should
1707 #better survive longer than \$obj.
1708 #
1709 #=over
1710 #
1711 #=item C<\$object_of_type_$name-E<gt>_to_ptr()>
1712 #
1713 #Converts an object of type C<$name> to an object of type C<$ptrname>.
1714 #
1715 #=item C<$name-E<gt>new()>
1716 #
1717 #Creates an empty object of type C<$name>.  The corresponding packed
1718 #string is zeroed out.
1719 #
1720 #=item C<$methods>
1721 #
1722 #return the current value of the corresponding element if called
1723 #without additional arguments.  Set the element to the supplied value
1724 #(and return the new value) if called with an additional argument.
1725 #
1726 #Applicable to objects of type C<$ptrname>.
1727 #
1728 #=back
1729 #
1730 EOF
1731   $pod =~ s/^\#//gm;
1732   return $pod;
1733 }
1734
1735 # Should be called before any actual call to normalize_type().
1736 sub get_typemap {
1737   # We do not want to read ./typemap by obvios reasons.
1738   my @tm =  qw(../../../typemap ../../typemap ../typemap);
1739   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
1740   unshift @tm, $stdtypemap;
1741   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
1742
1743   # Start with useful default values
1744   $typemap{float} = 'T_NV';
1745
1746   foreach my $typemap (@tm) {
1747     next unless -e $typemap ;
1748     # skip directories, binary files etc.
1749     warn " Scanning $typemap\n";
1750     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1751       unless -T $typemap ;
1752     open(TYPEMAP, $typemap)
1753       or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1754     my $mode = 'Typemap';
1755     while (<TYPEMAP>) {
1756       next if /^\s*\#/;
1757       if (/^INPUT\s*$/)   { $mode = 'Input'; next; }
1758       elsif (/^OUTPUT\s*$/)  { $mode = 'Output'; next; }
1759       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1760       elsif ($mode eq 'Typemap') {
1761         next if /^\s*($|\#)/ ;
1762         my ($type, $image);
1763         if ( ($type, $image) =
1764              /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1765              # This may reference undefined functions:
1766              and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
1767           $typemap{normalize_type($type)} = $image;
1768         }
1769       }
1770     }
1771     close(TYPEMAP) or die "Cannot close $typemap: $!";
1772   }
1773   %std_types = %types_seen;
1774   %types_seen = ();
1775 }
1776
1777
1778 sub normalize_type {            # Second arg: do not strip const's before \*
1779   my $type = shift;
1780   my $do_keep_deep_const = shift;
1781   # If $do_keep_deep_const this is heuristical only
1782   my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
1783   my $ignore_mods
1784     = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1785   if ($do_keep_deep_const) {    # Keep different compiled /RExen/o separately!
1786     $type =~ s/$ignore_mods//go;
1787   }
1788   else {
1789     $type =~ s/$ignore_mods//go;
1790   }
1791   $type =~ s/([^\s\w])/ $1 /g;
1792   $type =~ s/\s+$//;
1793   $type =~ s/^\s+//;
1794   $type =~ s/\s+/ /g;
1795   $type =~ s/\* (?=\*)/*/g;
1796   $type =~ s/\. \. \./.../g;
1797   $type =~ s/ ,/,/g;
1798   $types_seen{$type}++
1799     unless $type eq '...' or $type eq 'void' or $std_types{$type};
1800   $type;
1801 }
1802
1803 my $need_opaque;
1804
1805 sub assign_typemap_entry {
1806   my $type = shift;
1807   my $otype = $type;
1808   my $entry;
1809   if ($tmask and $type =~ /$tmask/) {
1810     print "Type $type matches -o mask\n" if $opt_d;
1811     $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1812   }
1813   elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1814     $type = normalize_type $type;
1815     print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1816     $entry = assign_typemap_entry($type);
1817   }
1818   # XXX good do better if our UV happens to be long long
1819   return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/;
1820   $entry ||= $typemap{$otype}
1821     || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1822   $typemap{$otype} = $entry;
1823   $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1824   return $entry;
1825 }
1826
1827 for (@vdecls) {
1828   print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
1829 }
1830
1831 if ($opt_x) {
1832   for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1833   if ($opt_a) {
1834     while (my($name, $struct) = each %structs) {
1835       print_accessors(\*XS, $name, $struct);
1836     }
1837   }
1838 }
1839
1840 close XS;
1841
1842 if (%types_seen) {
1843   my $type;
1844   warn "Writing $ext$modpname/typemap\n";
1845   open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1846
1847   for $type (sort keys %types_seen) {
1848     my $entry = assign_typemap_entry $type;
1849     print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
1850   }
1851
1852   print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1853 #############################################################################
1854 INPUT
1855 T_OPAQUE_STRUCT
1856         if (sv_derived_from($arg, \"${ntype}\")) {
1857             STRLEN len;
1858             char  *s = SvPV((SV*)SvRV($arg), len);
1859
1860             if (len != sizeof($var))
1861                 croak(\"Size %d of packed data != expected %d\",
1862                         len, sizeof($var));
1863             $var = *($type *)s;
1864         }
1865         else
1866             croak(\"$var is not of type ${ntype}\")
1867 #############################################################################
1868 OUTPUT
1869 T_OPAQUE_STRUCT
1870         sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1871 EOP
1872
1873   close TM or die "Cannot close typemap file for write: $!";
1874 }
1875
1876 } # if( ! $opt_X )
1877
1878 warn "Writing $ext$modpname/Makefile.PL\n";
1879 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
1880
1881 my $prereq_pm;
1882
1883 if ( $compat_version < 5.00702 and $new_test )
1884 {
1885   $prereq_pm = q%'Test::More'  =>  0%;
1886 }
1887 else
1888 {
1889   $prereq_pm = '';
1890 }
1891
1892 print PL <<"END";
1893 use $compat_version;
1894 use ExtUtils::MakeMaker;
1895 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
1896 # the contents of the Makefile that is written.
1897 WriteMakefile(
1898     NAME              => '$module',
1899     VERSION_FROM      => '$modfname.pm', # finds \$VERSION
1900     PREREQ_PM         => {$prereq_pm}, # e.g., Module::Name => 1.1
1901     (\$] >= 5.005 ?     ## Add these new keywords supported since 5.005
1902       (ABSTRACT_FROM  => '$modfname.pm', # retrieve abstract from module
1903        AUTHOR         => '$author <$email>') : ()),
1904 END
1905 if (!$opt_X) { # print C stuff, unless XS is disabled
1906   $opt_F = '' unless defined $opt_F;
1907   my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
1908   my $Ihelp = ($I ? '-I. ' : '');
1909   my $Icomment = ($I ? '' : <<EOC);
1910         # Insert -I. if you add *.h files later:
1911 EOC
1912
1913   print PL <<END;
1914     LIBS              => ['$extralibs'], # e.g., '-lm'
1915     DEFINE            => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1916 $Icomment    INC               => '$I', # e.g., '${Ihelp}-I/usr/include/other'
1917 END
1918
1919   my $C = grep {$_ ne "$modfname.c"}
1920     (glob '*.c'), (glob '*.cc'), (glob '*.C');
1921   my $Cpre = ($C ? '' : '# ');
1922   my $Ccomment = ($C ? '' : <<EOC);
1923         # Un-comment this if you add C files to link with later:
1924 EOC
1925
1926   print PL <<END;
1927 $Ccomment    ${Cpre}OBJECT            => '\$(O_FILES)', # link all the C files too
1928 END
1929 } # ' # Grr
1930 print PL ");\n";
1931 if (!$opt_c) {
1932   my $generate_code =
1933     WriteMakefileSnippet ( C_FILE =>       $constscfname,
1934                            XS_FILE =>      $constsxsfname,
1935                            DEFAULT_TYPE => $opt_t,
1936                            NAME =>         $module,
1937                            NAMES =>        \@const_names,
1938                  );
1939   print PL <<"END";
1940 if  (eval {require ExtUtils::Constant; 1}) {
1941   # If you edit these definitions to change the constants used by this module,
1942   # you will need to use the generated $constscfname and $constsxsfname
1943   # files to replace their "fallback" counterparts before distributing your
1944   # changes.
1945 $generate_code
1946 }
1947 else {
1948   use File::Copy;
1949   use File::Spec;
1950   foreach my \$file ('$constscfname', '$constsxsfname') {
1951     my \$fallback = File::Spec->catfile('$fallbackdirname', \$file);
1952     copy (\$fallback, \$file) or die "Can't copy \$fallback to \$file: \$!";
1953   }
1954 }
1955 END
1956
1957   eval $generate_code;
1958   if ($@) {
1959     warn <<"EOM";
1960 Attempting to test constant code in $ext$modpname/Makefile.PL:
1961 $generate_code
1962 __END__
1963 gave unexpected error $@
1964 Please report the circumstances of this bug in h2xs version $H2XS_VERSION
1965 using the perlbug script.
1966 EOM
1967   } else {
1968     my $fail;
1969
1970     foreach my $file ($constscfname, $constsxsfname) {
1971       my $fallback = File::Spec->catfile($fallbackdirname, $file);
1972       if (compare($file, $fallback)) {
1973         warn << "EOM";
1974 Files "$ext$modpname/$fallbackdirname/$file" and "$ext$modpname/$file" differ.
1975 EOM
1976         $fail++;
1977       }
1978     }
1979     if ($fail) {
1980       warn fill ('','', <<"EOM") . "\n";
1981 It appears that the code in $ext$modpname/Makefile.PL does not autogenerate
1982 the files $ext$modpname/$constscfname and $ext$modpname/$constsxsfname
1983 correctly.
1984
1985 Please report the circumstances of this bug in h2xs version $H2XS_VERSION
1986 using the perlbug script.
1987 EOM
1988     } else {
1989       unlink $constscfname, $constsxsfname;
1990     }
1991   }
1992 }
1993 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
1994
1995 # Create a simple README since this is a CPAN requirement
1996 # and it doesnt hurt to have one
1997 warn "Writing $ext$modpname/README\n";
1998 open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
1999 my $thisyear = (gmtime)[5] + 1900;
2000 my $rmhead = "$modpname version $TEMPLATE_VERSION";
2001 my $rmheadeq = "=" x length($rmhead);
2002
2003 my $rm_prereq;
2004
2005 if ( $compat_version < 5.00702 and $new_test )
2006 {
2007    $rm_prereq = 'Test::More';
2008 }
2009 else
2010 {
2011    $rm_prereq = 'blah blah blah';
2012 }
2013
2014 print RM <<_RMEND_;
2015 $rmhead
2016 $rmheadeq
2017
2018 The README is used to introduce the module and provide instructions on
2019 how to install the module, any machine dependencies it may have (for
2020 example C compilers and installed libraries) and any other information
2021 that should be provided before the module is installed.
2022
2023 A README file is required for CPAN modules since CPAN extracts the
2024 README file from a module distribution so that people browsing the
2025 archive can use it get an idea of the modules uses. It is usually a
2026 good idea to provide version information here so that people can
2027 decide whether fixes for the module are worth downloading.
2028
2029 INSTALLATION
2030
2031 To install this module type the following:
2032
2033    perl Makefile.PL
2034    make
2035    make test
2036    make install
2037
2038 DEPENDENCIES
2039
2040 This module requires these other modules and libraries:
2041
2042   $rm_prereq
2043
2044 COPYRIGHT AND LICENCE
2045
2046 Put the correct copyright and licence information here.
2047
2048 Copyright (C) $thisyear $author
2049
2050 This library is free software; you can redistribute it and/or modify
2051 it under the same terms as Perl itself.
2052
2053 _RMEND_
2054 close(RM) || die "Can't close $ext$modpname/README: $!\n";
2055
2056 my $testdir  = "t";
2057 my $testfile = "$testdir/1.t";
2058 unless (-d "$testdir") {
2059   mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n";
2060 }
2061 warn "Writing $ext$modpname/$testfile\n";
2062 my $tests = @const_names ? 2 : 1;
2063
2064 open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n";
2065
2066 print EX <<_END_;
2067 # Before `make install' is performed this script should be runnable with
2068 # `make test'. After `make install' it should work as `perl 1.t'
2069
2070 #########################
2071
2072 # change 'tests => $tests' to 'tests => last_test_to_print';
2073
2074 _END_
2075
2076 my $test_mod = 'Test::More';
2077
2078 if ( $old_test or ($compat_version < 5.007 and not $new_test ))
2079 {
2080   my $test_mod = 'Test';
2081
2082   print EX <<_END_;
2083 use Test;
2084 BEGIN { plan tests => $tests };
2085 use $module;
2086 ok(1); # If we made it this far, we're ok.
2087
2088 _END_
2089
2090    if (@const_names) {
2091      my $const_names = join " ", @const_names;
2092      print EX <<'_END_';
2093
2094 my $fail;
2095 foreach my $constname (qw(
2096 _END_
2097
2098      print EX wrap ("\t", "\t", $const_names);
2099      print EX (")) {\n");
2100
2101      print EX <<_END_;
2102   next if (eval "my \\\$a = \$constname; 1");
2103   if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
2104     print "# pass: \$\@";
2105   } else {
2106     print "# fail: \$\@";
2107     \$fail = 1;
2108   }
2109 }
2110 if (\$fail) {
2111   print "not ok 2\\n";
2112 } else {
2113   print "ok 2\\n";
2114 }
2115
2116 _END_
2117   }
2118 }
2119 else
2120 {
2121   print EX <<_END_;
2122 use Test::More tests => $tests;
2123 BEGIN { use_ok('$module') };
2124
2125 _END_
2126
2127    if (@const_names) {
2128      my $const_names = join " ", @const_names;
2129      print EX <<'_END_';
2130
2131 my $fail = 0;
2132 foreach my $constname (qw(
2133 _END_
2134
2135      print EX wrap ("\t", "\t", $const_names);
2136      print EX (")) {\n");
2137
2138      print EX <<_END_;
2139   next if (eval "my \\\$a = \$constname; 1");
2140   if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
2141     print "# pass: \$\@";
2142   } else {
2143     print "# fail: \$\@";
2144     \$fail = 1;
2145   }
2146
2147 }
2148
2149 ok( \$fail == 0 , 'Constants' );
2150 _END_
2151   }
2152 }
2153
2154 print EX <<_END_;
2155 #########################
2156
2157 # Insert your test code below, the $test_mod module is use()ed here so read
2158 # its man page ( perldoc $test_mod ) for help writing this test script.
2159
2160 _END_
2161
2162 close(EX) || die "Can't close $ext$modpname/$testfile: $!\n";
2163
2164 unless ($opt_C) {
2165   warn "Writing $ext$modpname/Changes\n";
2166   $" = ' ';
2167   open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
2168   @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
2169   print EX <<EOP;
2170 Revision history for Perl extension $module.
2171
2172 $TEMPLATE_VERSION  @{[scalar localtime]}
2173 \t- original version; created by h2xs $H2XS_VERSION with options
2174 \t\t@ARGS
2175
2176 EOP
2177   close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
2178 }
2179
2180 warn "Writing $ext$modpname/MANIFEST\n";
2181 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
2182 my @files = grep { -f } (<*>, <t/*>, <$fallbackdirname/*>);
2183 if (!@files) {
2184   eval {opendir(D,'.');};
2185   unless ($@) { @files = readdir(D); closedir(D); }
2186 }
2187 if (!@files) { @files = map {chomp && $_} `ls`; }
2188 if ($^O eq 'VMS') {
2189   foreach (@files) {
2190     # Clip trailing '.' for portability -- non-VMS OSs don't expect it
2191     s%\.$%%;
2192     # Fix up for case-sensitive file systems
2193     s/$modfname/$modfname/i && next;
2194     $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
2195     $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
2196   }
2197 }
2198 print MANI join("\n",@files), "\n";
2199 close MANI;
2200 !NO!SUBS!
2201
2202 close OUT or die "Can't close $file: $!";
2203 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
2204 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
2205 chdir $origdir;