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