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