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.6.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 compatible 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 = sprintf("%d.%03d%03d",$maj,$min,$sub);
 662     }
 663 } else {
 664     my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d*)/;
 665     $sub ||= 0;
 666     warn sprintf <<'EOF', $maj,$min,$sub;
 667 Defaulting to backwards compatibility with perl %d.%d.%d
 668 If you intend this module to be compatible with earlier perl versions, please
 669 specify a minimum perl version with the -b option.
 670
 671 EOF
 672 }
 673
 674 if( $opt_B ){
 675     $TEMPLATE_VERSION = '0.00_01';
 676 }
 677
 678 if( $opt_v ){
 679         $TEMPLATE_VERSION = $opt_v;
 680
 681     # check if it is numeric
 682     my $temp_version = $TEMPLATE_VERSION;
 683     my $beta_version = $temp_version =~ s/(\d)_(\d\d)/$1$2/;
 684     my $notnum;
 685     {
 686         local $SIG{__WARN__} = sub { $notnum = 1 };
 687         use warnings 'numeric';
 688         $temp_version = 0+$temp_version;
 689     }
 690
 691     if ($notnum) {
 692         my $module = $opt_n || 'Your::Module';
 693         warn <<"EOF";
 694 You have specified a non-numeric version.  Unless you supply an
 695 appropriate VERSION class method, users may not be able to specify a
 696 minimum required version with C<use $module versionnum>.
 697
 698 EOF
 699     }
 700     else {
 701         $opt_B = $beta_version;
 702     }
 703 }
 704
 705 # -A implies -c.
 706 $skip_autoloader = $opt_c = 1 if $opt_A;
 707
 708 # -X implies -c and -f
 709 $opt_c = $opt_f = 1 if $opt_X;
 710
 711 $opt_t ||= 'IV';
 712
 713 my %const_xsub;
 714 %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
 715
 716 my $extralibs = '';
 717
 718 my @path_h;
 719
 720 while (my $arg = shift) {
 721     if ($arg =~ /^-l/i) {
 722         $extralibs .= "$arg ";
 723         next;
 724     }
 725     last if $extralibs;
 726     push(@path_h, $arg);
 727 }
 728
 729 usage "Must supply header file or module name\n"
 730         unless (@path_h or $opt_n);
 731
 732 my $fmask;
 733 my $tmask;
 734
 735 $fmask = qr{$opt_M} if defined $opt_M;
 736 $tmask = qr{$opt_o} if defined $opt_o;
 737 my $tmask_all = $tmask && $opt_o eq '.';
 738
 739 if ($opt_x) {
 740   eval {require C::Scan; 1}
 741     or die <<EOD;
 742 C::Scan required if you use -x option.
 743 To install C::Scan, execute
 744    perl -MCPAN -e "install C::Scan"
 745 EOD
 746   unless ($tmask_all) {
 747     $C::Scan::VERSION >= 0.70
 748       or die <<EOD;
 749 C::Scan v. 0.70 or later required unless you use -o . option.
 750 You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
 751 To install C::Scan, execute
 752    perl -MCPAN -e "install C::Scan"
 753 EOD
 754   }
 755   if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) {
 756     die <<EOD;
 757 C::Scan v. 0.73 or later required to use -m or -a options.
 758 You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
 759 To install C::Scan, execute
 760    perl -MCPAN -e "install C::Scan"
 761 EOD
 762   }
 763 }
 764 elsif ($opt_o or $opt_F) {
 765   warn <<EOD if $opt_o;
 766 Option -o does not make sense without -x.
 767 EOD
 768   warn <<EOD if $opt_F and $opt_X ;
 769 Option -F does not make sense with -X.
 770 EOD
 771 }
 772
 773 my @path_h_ini = @path_h;
 774 my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
 775
 776 my $module = $opt_n;
 777
 778 if( @path_h ){
 779     use File::Spec;
 780     my @paths;
 781     my $pre_sub_tri_graphs = 1;
 782     if ($^O eq 'VMS') {  # Consider overrides of default location
 783       # XXXX This is not equivalent to what the older version did:
 784       #         it was looking at $hadsys header-file per header-file...
 785       my($hadsys) = grep s!^sys/!!i , @path_h;
 786       @paths = qw( Sys$Library VAXC$Include );
 787       push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
 788       push @paths, qw( DECC$Library_Include DECC$System_Include );
 789     }
 790     else {
 791       @paths = (File::Spec->curdir(), $Config{usrinc},
 792                 (split / +/, $Config{locincpth} // ""), '/usr/include');
 793     }
 794     foreach my $path_h (@path_h) {
 795         $name ||= $path_h;
 796     $module ||= do {
 797       $name =~ s/\.h$//;
 798       if ( $name !~ /::/ ) {
 799         $name =~ s#^.*/##;
 800         $name = "\u$name";
 801       }
 802       $name;
 803     };
 804
 805     if( $path_h =~ s#::#/#g && $opt_n ){
 806         warn "Nesting of headerfile ignored with -n\n";
 807     }
 808     $path_h .= ".h" unless $path_h =~ /\.h$/;
 809     my $fullpath = $path_h;
 810     $path_h =~ s/,.*$// if $opt_x;
 811     $fullpath{$path_h} = $fullpath;
 812
 813     # Minor trickery: we can't chdir() before we processed the headers
 814     # (so know the name of the extension), but the header may be in the
 815     # extension directory...
 816     my $tmp_path_h = $path_h;
 817     my $rel_path_h = $path_h;
 818     my @dirs = @paths;
 819     if (not -f $path_h) {
 820       my $found;
 821       for my $dir (@paths) {
 822         $found++, last
 823           if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
 824       }
 825       if ($found) {
 826         $rel_path_h = $path_h;
 827         $fullpath{$path_h} = $fullpath;
 828       } else {
 829         (my $epath = $module) =~ s,::,/,g;
 830         $epath = File::Spec->catdir('ext', $epath) if -d 'ext';
 831         $rel_path_h = File::Spec->catfile($epath, $tmp_path_h);
 832         $path_h = $tmp_path_h;  # Used during -x
 833         push @dirs, $epath;
 834       }
 835     }
 836
 837     if (!$opt_c) {
 838       die "Can't find $tmp_path_h in @dirs\n"
 839         if ( ! $opt_f && ! -f "$rel_path_h" );
 840       # Scan the header file (we should deal with nested header files)
 841       # Record the names of simple #define constants into const_names
 842             # Function prototypes are processed below.
 843       open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n";
 844     defines:
 845       while (<CH>) {
 846         if ($pre_sub_tri_graphs) {
 847             # Preprocess all tri-graphs
 848             # including things stuck in quoted string constants.
 849             s/\?\?=/#/g;                         # | ??=|  #|
 850             s/\?\?\!/|/g;                        # | ??!|  ||
 851             s/\?\?'/^/g;                         # | ??'|  ^|
 852             s/\?\?\(/[/g;                        # | ??(|  [|
 853             s/\?\?\)/]/g;                        # | ??)|  ]|
 854             s/\?\?\-/~/g;                        # | ??-|  ~|
 855             s/\?\?\//\\/g;                       # | ??/|  \|
 856             s/\?\?</{/g;                         # | ??<|  {|
 857             s/\?\?>/}/g;                         # | ??>|  }|
 858         }
 859         if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) {
 860             my $def = $1;
 861             my $rest = $2;
 862             $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
 863             $rest =~ s/^\s+//;
 864             $rest =~ s/\s+$//;
 865             if ($rest eq '') {
 866               print("Skip empty $def\n") if $opt_d;
 867               next defines;
 868             }
 869             # Cannot do: (-1) and ((LHANDLE)3) are OK:
 870             #print("Skip non-wordy $def => $rest\n"),
 871             #  next defines if $rest =~ /[^\w\$]/;
 872             if ($rest =~ /"/) {
 873               print("Skip stringy $def => $rest\n") if $opt_d;
 874               next defines;
 875             }
 876             print "Matched $_ ($def)\n" if $opt_d;
 877             $seen_define{$def} = $rest;
 878             $_ = $def;
 879             next if /^_.*_h_*$/i; # special case, but for what?
 880             if (defined $opt_p) {
 881               if (!/^$opt_p(\d)/) {
 882                 ++$prefix{$_} if s/^$opt_p//;
 883               }
 884               else {
 885                 warn "can't remove $opt_p prefix from '$_'!\n";
 886               }
 887             }
 888             $prefixless{$def} = $_;
 889             if (!$fmask or /$fmask/) {
 890                 print "... Passes mask of -M.\n" if $opt_d and $fmask;
 891                 $const_names{$_}++;
 892             }
 893           }
 894       }
 895       if (defined $opt_e and !$opt_e) {
 896         close(CH);
 897       }
 898       else {
 899         # Work from miniperl too - on "normal" systems
 900         my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' || 0;
 901         seek CH, 0, $SEEK_SET;
 902         my $src = do { local $/; <CH> };
 903         close CH;
 904         no warnings 'uninitialized';
 905
 906         # Remove C and C++ comments
 907         $src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs;
 908         $src =~ s#//.*$##gm;
 909
 910         while ($src =~ /\benum\s*([\w_]*)\s*\{\s([^}]+)\}/gsc) {
 911             my ($enum_name, $enum_body) = ($1, $2);
 912             # skip enums matching $opt_e
 913             next if $opt_e && $enum_name =~ /$opt_e/;
 914             my $val = 0;
 915             for my $item (split /,/, $enum_body) {
 916                 next if $item =~ /\A\s*\Z/;
 917                 my ($key, $declared_val) = $item =~ /(\w+)\s*(?:=\s*(.*))?/;
 918                 $val = defined($declared_val) && length($declared_val) ? $declared_val : 1 + $val;
 919                 $seen_define{$key} = $val;
 920                 $const_names{$key} = { name => $key, macro => 1 };
 921             }
 922         } # while (...)
 923       } # if (!defined $opt_e or $opt_e)
 924     }
 925     }
 926 }
 927
 928 # Save current directory so that C::Scan can use it
 929 my $cwd = File::Spec->rel2abs( File::Spec->curdir );
 930
 931 # As Ilya suggested, use a name that contains - and then it can't clash with
 932 # the names of any packages. A directory 'fallback' will clash with any
 933 # new pragmata down the fallback:: tree, but that seems unlikely.
 934 my $constscfname = 'const-c.inc';
 935 my $constsxsfname = 'const-xs.inc';
 936 my $fallbackdirname = 'fallback';
 937
 938 my $ext = chdir 'ext' ? 'ext/' : '';
 939
 940 my @modparts  = split(/::/,$module);
 941 my $modpname  = join('-', @modparts);
 942 my $modfname  = pop @modparts;
 943 my $modpmdir  = join '/', 'lib', @modparts;
 944 my $modpmname = join '/', $modpmdir, $modfname.'.pm';
 945
 946 if ($opt_O) {
 947         warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
 948 }
 949 else {
 950         die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
 951 }
 952 -d "$modpname"   || mkpath([$modpname], 0, 0775);
 953 chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
 954
 955 my %types_seen;
 956 my %std_types;
 957 my $fdecls = [];
 958 my $fdecls_parsed = [];
 959 my $typedef_rex;
 960 my %typedefs_pre;
 961 my %known_fnames;
 962 my %structs;
 963
 964 my @fnames;
 965 my @fnames_no_prefix;
 966 my %vdecl_hash;
 967 my @vdecls;
 968
 969 if( ! $opt_X ){  # use XS, unless it was disabled
 970   unless ($skip_ppport) {
 971     require Devel::PPPort;
 972     warn "Writing $ext$modpname/ppport.h\n";
 973     Devel::PPPort::WriteFile('ppport.h')
 974         || die "Can't create $ext$modpname/ppport.h: $!\n";
 975   }
 976   open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
 977   if ($opt_x) {
 978     warn "Scanning typemaps...\n";
 979     get_typemap();
 980     my @td;
 981     my @good_td;
 982     my $addflags = $opt_F || '';
 983
 984     foreach my $filename (@path_h) {
 985       my $c;
 986       my $filter;
 987
 988       if ($fullpath{$filename} =~ /,/) {
 989         $filename = $`;
 990         $filter = $';
 991       }
 992       warn "Scanning $filename for functions...\n";
 993       my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X);
 994       $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
 995         'add_cppflags' => $addflags, 'c_styles' => \@styles;
 996       $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]);
 997
 998       $c->get('keywords')->{'__restrict'} = 1;
 999
1000       push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
1001       push(@$fdecls, @{$c->get('fdecls')});
1002
1003       push @td, @{$c->get('typedefs_maybe')};
1004       if ($opt_a) {
1005         my $structs = $c->get('typedef_structs');
1006         @structs{keys %$structs} = values %$structs;
1007       }
1008
1009       if ($opt_m) {
1010         %vdecl_hash = %{ $c->get('vdecl_hash') };
1011         @vdecls = sort keys %vdecl_hash;
1012         for (local $_ = 0; $_ < @vdecls; ++$_) {
1013           my $var = $vdecls[$_];
1014           my($type, $post) = @{ $vdecl_hash{$var} };
1015           if (defined $post) {
1016             warn "Can't handle variable '$type $var $post', skipping.\n";
1017             splice @vdecls, $_, 1;
1018             redo;
1019           }
1020           $type = normalize_type($type);
1021           $vdecl_hash{$var} = $type;
1022         }
1023       }
1024
1025       unless ($tmask_all) {
1026         warn "Scanning $filename for typedefs...\n";
1027         my $td = $c->get('typedef_hash');
1028         # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
1029         my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
1030         push @good_td, @f_good_td;
1031         @typedefs_pre{@f_good_td}  = map $_->[0], @$td{@f_good_td};
1032       }
1033     }
1034     { local $" = '|';
1035       $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
1036     }
1037     %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
1038     if ($fmask) {
1039       my @good;
1040       for my $i (0..$#$fdecls_parsed) {
1041         next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
1042         push @good, $i;
1043         print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
1044           if $opt_d;
1045       }
1046       $fdecls = [@$fdecls[@good]];
1047       $fdecls_parsed = [@$fdecls_parsed[@good]];
1048     }
1049     @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
1050     # Sort declarations:
1051     {
1052       my %h = map( ($_->[1], $_), @$fdecls_parsed);
1053       $fdecls_parsed = [ @h{@fnames} ];
1054     }
1055     @fnames_no_prefix = @fnames;
1056     @fnames_no_prefix
1057       = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix
1058          if defined $opt_p;
1059     # Remove macros which expand to typedefs
1060     print "Typedefs are @td.\n" if $opt_d;
1061     my %td = map {($_, $_)} @td;
1062     # Add some other possible but meaningless values for macros
1063     for my $k (qw(char double float int long short unsigned signed void)) {
1064       $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
1065     }
1066     # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
1067     my $n = 0;
1068     my %bad_macs;
1069     while (keys %td > $n) {
1070       $n = keys %td;
1071       my ($k, $v);
1072       while (($k, $v) = each %seen_define) {
1073         # print("found '$k'=>'$v'\n"),
1074         $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
1075       }
1076     }
1077     # Now %bad_macs contains names of bad macros
1078     for my $k (keys %bad_macs) {
1079       delete $const_names{$prefixless{$k}};
1080       print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
1081     }
1082   }
1083 }
1084 my (@const_specs, @const_names);
1085
1086 for (sort(keys(%const_names))) {
1087     my $v = $const_names{$_};
1088
1089     push(@const_specs, ref($v) ? $v : $_);
1090     push(@const_names, $_);
1091 }
1092
1093 -d $modpmdir || mkpath([$modpmdir], 0, 0775);
1094 open(PM, ">$modpmname") || die "Can't create $ext$modpname/$modpmname: $!\n";
1095
1096 $" = "\n\t";
1097 warn "Writing $ext$modpname/$modpmname\n";
1098
1099 print PM <<"END";
1100 package $module;
1101
1102 use $compat_version;
1103 END
1104
1105 print PM <<"END" unless $skip_strict;
1106 use strict;
1107 END
1108
1109 print PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006;
1110
1111 unless( $opt_X || $opt_c || $opt_A ){
1112         # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
1113         # will want Carp.
1114         print PM <<'END';
1115 use Carp;
1116 END
1117 }
1118
1119 print PM <<'END' unless $skip_exporter;
1120
1121 require Exporter;
1122 END
1123
1124 my $use_Dyna = (not $opt_X and $compat_version < 5.006 and not $use_xsloader);
1125 print PM <<"END" if $use_Dyna;  # use DynaLoader, unless XS was disabled
1126 require DynaLoader;
1127 END
1128
1129
1130 # Are we using AutoLoader or not?
1131 unless ($skip_autoloader) { # no autoloader whatsoever.
1132         unless ($opt_c) { # we're doing the AUTOLOAD
1133                 print PM "use AutoLoader;\n";
1134         }
1135         else {
1136                 print PM "use AutoLoader qw(AUTOLOAD);\n"
1137         }
1138 }
1139
1140 if ( $compat_version < 5.006 ) {
1141     my $vars = '$VERSION @ISA';
1142     $vars .= ' @EXPORT @EXPORT_OK %EXPORT_TAGS' unless $skip_exporter;
1143     $vars .= ' $AUTOLOAD' unless $opt_X || $opt_c || $opt_A;
1144     $vars .= ' $XS_VERSION' if $opt_B && !$opt_X;
1145     print PM "use vars qw($vars);";
1146 }
1147
1148 # Determine @ISA.
1149 my @modISA;
1150 push @modISA, 'Exporter'        unless $skip_exporter;
1151 push @modISA, 'DynaLoader'      if $use_Dyna;  # no XS
1152 my $myISA = "our \@ISA = qw(@modISA);";
1153 $myISA =~ s/^our // if $compat_version < 5.006;
1154
1155 print PM "\n$myISA\n\n";
1156
1157 my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
1158
1159 my $tmp='';
1160 $tmp .= <<"END" unless $skip_exporter;
1161 # Items to export into callers namespace by default. Note: do not export
1162 # names by default without a very good reason. Use EXPORT_OK instead.
1163 # Do not simply export all your public functions/methods/constants.
1164
1165 # This allows declaration       use $module ':all';
1166 # If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
1167 # will save memory.
1168 our %EXPORT_TAGS = ( 'all' => [ qw(
1169         @exported_names
1170 ) ] );
1171
1172 our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
1173
1174 our \@EXPORT = qw(
1175         @const_names
1176 );
1177
1178 END
1179
1180 $tmp .= "our \$VERSION = '$TEMPLATE_VERSION';\n";
1181 if ($opt_B) {
1182     $tmp .= "our \$XS_VERSION = \$VERSION;\n" unless $opt_X;
1183     $tmp .= "\$VERSION = eval \$VERSION;  # see L<perlmodstyle>\n";
1184 }
1185 $tmp .= "\n";
1186
1187 $tmp =~ s/^our //mg if $compat_version < 5.006;
1188 print PM $tmp;
1189
1190 if (@vdecls) {
1191     printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
1192 }
1193
1194
1195 print PM autoload ($module, $compat_version) unless $opt_c or $opt_X;
1196
1197 if( ! $opt_X ){ # print bootstrap, unless XS is disabled
1198   if ($use_Dyna) {
1199         $tmp = <<"END";
1200 bootstrap $module \$VERSION;
1201 END
1202   } else {
1203         $tmp = <<"END";
1204 require XSLoader;
1205 XSLoader::load('$module', \$VERSION);
1206 END
1207   }
1208   $tmp =~ s:\$VERSION:\$XS_VERSION:g if $opt_B;
1209   print PM $tmp;
1210 }
1211
1212 # tying the variables can happen only after bootstrap
1213 if (@vdecls) {
1214     printf PM <<END;
1215 {
1216 @{[ join "\n", map "    _tievar_$_(\$$_);", @vdecls ]}
1217 }
1218
1219 END
1220 }
1221
1222 my $after;
1223 if( $opt_P ){ # if POD is disabled
1224         $after = '__END__';
1225 }
1226 else {
1227         $after = '=cut';
1228 }
1229
1230 print PM <<"END";
1231
1232 # Preloaded methods go here.
1233 END
1234
1235 print PM <<"END" unless $opt_A;
1236
1237 # Autoload methods go after $after, and are processed by the autosplit program.
1238 END
1239
1240 print PM <<"END";
1241
1242 1;
1243 __END__
1244 END
1245
1246 my ($email,$author,$licence);
1247
1248 eval {
1249        my $username;
1250        ($username,$author) = (getpwuid($>))[0,6];
1251        if (defined $username && defined $author) {
1252            $author =~ s/,.*$//; # in case of sub fields
1253            my $domain = $Config{'mydomain'};
1254            $domain =~ s/^\.//;
1255            $email = "$username\@$domain";
1256        }
1257      };
1258
1259 $author =~ s/'/\\'/g if defined $author;
1260 $author ||= "A. U. Thor";
1261 $email  ||= 'a.u.thor@a.galaxy.far.far.away';
1262
1263 $licence = sprintf << "DEFAULT", $^V;
1264 Copyright (C) ${\(1900 + (localtime) [5])} by $author
1265
1266 This library is free software; you can redistribute it and/or modify
1267 it under the same terms as Perl itself, either Perl version %vd or,
1268 at your option, any later version of Perl 5 you may have available.
1269 DEFAULT
1270
1271 my $revhist = '';
1272 $revhist = <<EOT if $opt_C;
1273 #
1274 #=head1 HISTORY
1275 #
1276 #=over 8
1277 #
1278 #=item $TEMPLATE_VERSION
1279 #
1280 #Original version; created by h2xs $H2XS_VERSION with options
1281 #
1282 #  @ARGS
1283 #
1284 #=back
1285 #
1286 EOT
1287
1288 my $exp_doc = $skip_exporter ? '' : <<EOD;
1289 #
1290 #=head2 EXPORT
1291 #
1292 #None by default.
1293 #
1294 EOD
1295
1296 if (@const_names and not $opt_P) {
1297   $exp_doc .= <<EOD unless $skip_exporter;
1298 #=head2 Exportable constants
1299 #
1300 #  @{[join "\n  ", @const_names]}
1301 #
1302 EOD
1303 }
1304
1305 if (defined $fdecls and @$fdecls and not $opt_P) {
1306   $exp_doc .= <<EOD unless $skip_exporter;
1307 #=head2 Exportable functions
1308 #
1309 EOD
1310
1311 #  $exp_doc .= <<EOD if $opt_p;
1312 #When accessing these functions from Perl, prefix C<$opt_p> should be removed.
1313 #
1314 #EOD
1315   $exp_doc .= <<EOD unless $skip_exporter;
1316 #  @{[join "\n  ", @known_fnames{@fnames}]}
1317 #
1318 EOD
1319 }
1320
1321 my $meth_doc = '';
1322
1323 if ($opt_x && $opt_a) {
1324   my($name, $struct);
1325   $meth_doc .= accessor_docs($name, $struct)
1326     while ($name, $struct) = each %structs;
1327 }
1328
1329 # Prefix the default licence with hash symbols.
1330 # Is this just cargo cult - it seems that the first thing that happens to this
1331 # block is that all the hashes are then s///g out.
1332 my $licence_hash = $licence;
1333 $licence_hash =~ s/^/#/gm;
1334
1335 my $pod;
1336 $pod = <<"END" unless $opt_P;
1337 ## Below is stub documentation for your module. You'd better edit it!
1338 #
1339 #=head1 NAME
1340 #
1341 #$module - Perl extension for blah blah blah
1342 #
1343 #=head1 SYNOPSIS
1344 #
1345 #  use $module;
1346 #  blah blah blah
1347 #
1348 #=head1 DESCRIPTION
1349 #
1350 #Stub documentation for $module, created by h2xs. It looks like the
1351 #author of the extension was negligent enough to leave the stub
1352 #unedited.
1353 #
1354 #Blah blah blah.
1355 $exp_doc$meth_doc$revhist
1356 #
1357 #=head1 SEE ALSO
1358 #
1359 #Mention other useful documentation such as the documentation of
1360 #related modules or operating system documentation (such as man pages
1361 #in UNIX), or any relevant external documentation such as RFCs or
1362 #standards.
1363 #
1364 #If you have a mailing list set up for your module, mention it here.
1365 #
1366 #If you have a web site set up for your module, mention it here.
1367 #
1368 #=head1 AUTHOR
1369 #
1370 #$author, E<lt>${email}E<gt>
1371 #
1372 #=head1 COPYRIGHT AND LICENSE
1373 #
1374 $licence_hash
1375 #
1376 #=cut
1377 END
1378
1379 $pod =~ s/^\#//gm unless $opt_P;
1380 print PM $pod unless $opt_P;
1381
1382 close PM;
1383
1384
1385 if( ! $opt_X ){ # print XS, unless it is disabled
1386 warn "Writing $ext$modpname/$modfname.xs\n";
1387
1388 print XS <<"END";
1389 #include "EXTERN.h"
1390 #include "perl.h"
1391 #include "XSUB.h"
1392
1393 END
1394
1395 print XS <<"END" unless $skip_ppport;
1396 #include "ppport.h"
1397
1398 END
1399
1400 if( @path_h ){
1401     foreach my $path_h (@path_h_ini) {
1402         my($h) = $path_h;
1403         $h =~ s#^/usr/include/##;
1404         if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
1405         print XS qq{#include <$h>\n};
1406     }
1407     print XS "\n";
1408 }
1409
1410 print XS <<"END" if $opt_g;
1411
1412 /* Global Data */
1413
1414 #define MY_CXT_KEY "${module}::_guts" XS_VERSION
1415
1416 typedef struct {
1417     /* Put Global Data in here */
1418     int dummy;          /* you can access this elsewhere as MY_CXT.dummy */
1419 } my_cxt_t;
1420
1421 START_MY_CXT
1422
1423 END
1424
1425 my %pointer_typedefs;
1426 my %struct_typedefs;
1427
1428 sub td_is_pointer {
1429   my $type = shift;
1430   my $out = $pointer_typedefs{$type};
1431   return $out if defined $out;
1432   my $otype = $type;
1433   $out = ($type =~ /\*$/);
1434   # This converts only the guys which do not have trailing part in the typedef
1435   if (not $out
1436       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1437     $type = normalize_type($type);
1438     print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1439       if $opt_d;
1440     $out = td_is_pointer($type);
1441   }
1442   return ($pointer_typedefs{$otype} = $out);
1443 }
1444
1445 sub td_is_struct {
1446   my $type = shift;
1447   my $out = $struct_typedefs{$type};
1448   return $out if defined $out;
1449   my $otype = $type;
1450   $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
1451   # This converts only the guys which do not have trailing part in the typedef
1452   if (not $out
1453       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1454     $type = normalize_type($type);
1455     print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
1456       if $opt_d;
1457     $out = td_is_struct($type);
1458   }
1459   return ($struct_typedefs{$otype} = $out);
1460 }
1461
1462 print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1463
1464 if( ! $opt_c ) {
1465   # We write the "sample" files used when this module is built by perl without
1466   # ExtUtils::Constant.
1467   # h2xs will later check that these are the same as those generated by the
1468   # code embedded into Makefile.PL
1469   unless (-d $fallbackdirname) {
1470     mkdir "$fallbackdirname" or die "Cannot mkdir $fallbackdirname: $!\n";
1471   }
1472   warn "Writing $ext$modpname/$fallbackdirname/$constscfname\n";
1473   warn "Writing $ext$modpname/$fallbackdirname/$constsxsfname\n";
1474   my $cfallback = File::Spec->catfile($fallbackdirname, $constscfname);
1475   my $xsfallback = File::Spec->catfile($fallbackdirname, $constsxsfname);
1476   WriteConstants ( C_FILE =>       $cfallback,
1477                    XS_FILE =>      $xsfallback,
1478                    DEFAULT_TYPE => $opt_t,
1479                    NAME =>         $module,
1480                    NAMES =>        \@const_specs,
1481                  );
1482   print XS "#include \"$constscfname\"\n";
1483 }
1484
1485
1486 my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
1487
1488 # Now switch from C to XS by issuing the first MODULE declaration:
1489 print XS <<"END";
1490
1491 MODULE = $module                PACKAGE = $module               $prefix
1492
1493 END
1494
1495 # If a constant() function was #included then output a corresponding
1496 # XS declaration:
1497 print XS "INCLUDE: $constsxsfname\n" unless $opt_c;
1498
1499 print XS <<"END" if $opt_g;
1500
1501 BOOT:
1502 {
1503     MY_CXT_INIT;
1504     /* If any of the fields in the my_cxt_t struct need
1505        to be initialised, do it here.
1506      */
1507 }
1508
1509 END
1510
1511 foreach (sort keys %const_xsub) {
1512     print XS <<"END";
1513 char *
1514 $_()
1515
1516     CODE:
1517 #ifdef $_
1518         RETVAL = $_;
1519 #else
1520         croak("Your vendor has not defined the $module macro $_");
1521 #endif
1522
1523     OUTPUT:
1524         RETVAL
1525
1526 END
1527 }
1528
1529 my %seen_decl;
1530 my %typemap;
1531
1532 sub print_decl {
1533   my $fh = shift;
1534   my $decl = shift;
1535   my ($type, $name, $args) = @$decl;
1536   return if $seen_decl{$name}++; # Need to do the same for docs as well?
1537
1538   my @argnames = map {$_->[1]} @$args;
1539   my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
1540   if ($opt_k) {
1541     s/^\s*const\b\s*// for @argtypes;
1542   }
1543   my @argarrays = map { $_->[4] || '' } @$args;
1544   my $numargs = @$args;
1545   if ($numargs and $argtypes[-1] eq '...') {
1546     $numargs--;
1547     $argnames[-1] = '...';
1548   }
1549   local $" = ', ';
1550   $type = normalize_type($type, 1);
1551
1552   print $fh <<"EOP";
1553
1554 $type
1555 $name(@argnames)
1556 EOP
1557
1558   for my $arg (0 .. $numargs - 1) {
1559     print $fh <<"EOP";
1560         $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
1561 EOP
1562   }
1563 }
1564
1565 sub print_tievar_subs {
1566   my($fh, $name, $type) = @_;
1567   print $fh <<END;
1568 I32
1569 _get_$name(IV index, SV *sv) {
1570     dSP;
1571     PUSHMARK(SP);
1572     XPUSHs(sv);
1573     PUTBACK;
1574     (void)call_pv("$module\::_get_$name", G_DISCARD);
1575     return (I32)0;
1576 }
1577
1578 I32
1579 _set_$name(IV index, SV *sv) {
1580     dSP;
1581     PUSHMARK(SP);
1582     XPUSHs(sv);
1583     PUTBACK;
1584     (void)call_pv("$module\::_set_$name", G_DISCARD);
1585     return (I32)0;
1586 }
1587
1588 END
1589 }
1590
1591 sub print_tievar_xsubs {
1592   my($fh, $name, $type) = @_;
1593   print $fh <<END;
1594 void
1595 _tievar_$name(sv)
1596         SV* sv
1597     PREINIT:
1598         struct ufuncs uf;
1599     CODE:
1600         uf.uf_val = &_get_$name;
1601         uf.uf_set = &_set_$name;
1602         uf.uf_index = (IV)&_get_$name;
1603         sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1604
1605 void
1606 _get_$name(THIS)
1607         $type THIS = NO_INIT
1608     CODE:
1609         THIS = $name;
1610     OUTPUT:
1611         SETMAGIC: DISABLE
1612         THIS
1613
1614 void
1615 _set_$name(THIS)
1616         $type THIS
1617     CODE:
1618         $name = THIS;
1619
1620 END
1621 }
1622
1623 sub print_accessors {
1624   my($fh, $name, $struct) = @_;
1625   return unless defined $struct && $name !~ /\s|_ANON/;
1626   $name = normalize_type($name);
1627   my $ptrname = normalize_type("$name *");
1628   print $fh <<"EOF";
1629
1630 MODULE = $module                PACKAGE = ${name}               $prefix
1631
1632 $name *
1633 _to_ptr(THIS)
1634         $name THIS = NO_INIT
1635     PROTOTYPE: \$
1636     CODE:
1637         if (sv_derived_from(ST(0), "$name")) {
1638             STRLEN len;
1639             char *s = SvPV((SV*)SvRV(ST(0)), len);
1640             if (len != sizeof(THIS))
1641                 croak("Size \%d of packed data != expected \%d",
1642                         len, sizeof(THIS));
1643             RETVAL = ($name *)s;
1644         }
1645         else
1646             croak("THIS is not of type $name");
1647     OUTPUT:
1648         RETVAL
1649
1650 $name
1651 new(CLASS)
1652         char *CLASS = NO_INIT
1653     PROTOTYPE: \$
1654     CODE:
1655         Zero((void*)&RETVAL, sizeof(RETVAL), char);
1656     OUTPUT:
1657         RETVAL
1658
1659 MODULE = $module                PACKAGE = ${name}Ptr            $prefix
1660
1661 EOF
1662   my @items = @$struct;
1663   while (@items) {
1664     my $item = shift @items;
1665     if ($item->[0] =~ /_ANON/) {
1666       if (defined $item->[2]) {
1667         push @items, map [
1668           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1669         ], @{ $structs{$item->[0]} };
1670       } else {
1671         push @items, @{ $structs{$item->[0]} };
1672       }
1673     } else {
1674       my $type = normalize_type($item->[0]);
1675       my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
1676       print $fh <<"EOF";
1677 $ttype
1678 $item->[2](THIS, __value = NO_INIT)
1679         $ptrname THIS
1680         $type __value
1681     PROTOTYPE: \$;\$
1682     CODE:
1683         if (items > 1)
1684             THIS->$item->[-1] = __value;
1685         RETVAL = @{[
1686             $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1687         ]};
1688     OUTPUT:
1689         RETVAL
1690
1691 EOF
1692     }
1693   }
1694 }
1695
1696 sub accessor_docs {
1697   my($name, $struct) = @_;
1698   return unless defined $struct && $name !~ /\s|_ANON/;
1699   $name = normalize_type($name);
1700   my $ptrname = $name . 'Ptr';
1701   my @items = @$struct;
1702   my @list;
1703   while (@items) {
1704     my $item = shift @items;
1705     if ($item->[0] =~ /_ANON/) {
1706       if (defined $item->[2]) {
1707         push @items, map [
1708           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1709         ], @{ $structs{$item->[0]} };
1710       } else {
1711         push @items, @{ $structs{$item->[0]} };
1712       }
1713     } else {
1714       push @list, $item->[2];
1715     }
1716   }
1717   my $methods = (join '(...)>, C<', @list) . '(...)';
1718
1719   my $pod = <<"EOF";
1720 #
1721 #=head2 Object and class methods for C<$name>/C<$ptrname>
1722 #
1723 #The principal Perl representation of a C object of type C<$name> is an
1724 #object of class C<$ptrname> which is a reference to an integer
1725 #representation of a C pointer.  To create such an object, one may use
1726 #a combination
1727 #
1728 #  my \$buffer = $name->new();
1729 #  my \$obj = \$buffer->_to_ptr();
1730 #
1731 #This exercises the following two methods, and an additional class
1732 #C<$name>, the internal representation of which is a reference to a
1733 #packed string with the C structure.  Keep in mind that \$buffer should
1734 #better survive longer than \$obj.
1735 #
1736 #=over
1737 #
1738 #=item C<\$object_of_type_$name-E<gt>_to_ptr()>
1739 #
1740 #Converts an object of type C<$name> to an object of type C<$ptrname>.
1741 #
1742 #=item C<$name-E<gt>new()>
1743 #
1744 #Creates an empty object of type C<$name>.  The corresponding packed
1745 #string is zeroed out.
1746 #
1747 #=item C<$methods>
1748 #
1749 #return the current value of the corresponding element if called
1750 #without additional arguments.  Set the element to the supplied value
1751 #(and return the new value) if called with an additional argument.
1752 #
1753 #Applicable to objects of type C<$ptrname>.
1754 #
1755 #=back
1756 #
1757 EOF
1758   $pod =~ s/^\#//gm;
1759   return $pod;
1760 }
1761
1762 # Should be called before any actual call to normalize_type().
1763 sub get_typemap {
1764   # We do not want to read ./typemap by obvios reasons.
1765   my @tm =  qw(../../../typemap ../../typemap ../typemap);
1766   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
1767   unshift @tm, $stdtypemap;
1768   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
1769
1770   # Start with useful default values
1771   $typemap{float} = 'T_NV';
1772
1773   foreach my $typemap (@tm) {
1774     next unless -e $typemap ;
1775     # skip directories, binary files etc.
1776     warn " Scanning $typemap\n";
1777     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1778       unless -T $typemap ;
1779     open(TYPEMAP, $typemap)
1780       or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1781     my $mode = 'Typemap';
1782     while (<TYPEMAP>) {
1783       next if /^\s*\#/;
1784       if (/^INPUT\s*$/)   { $mode = 'Input'; next; }
1785       elsif (/^OUTPUT\s*$/)  { $mode = 'Output'; next; }
1786       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1787       elsif ($mode eq 'Typemap') {
1788         next if /^\s*($|\#)/ ;
1789         my ($type, $image);
1790         if ( ($type, $image) =
1791              /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1792              # This may reference undefined functions:
1793              and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
1794           $typemap{normalize_type($type)} = $image;
1795         }
1796       }
1797     }
1798     close(TYPEMAP) or die "Cannot close $typemap: $!";
1799   }
1800   %std_types = %types_seen;
1801   %types_seen = ();
1802 }
1803
1804
1805 sub normalize_type {            # Second arg: do not strip const's before \*
1806   my $type = shift;
1807   my $do_keep_deep_const = shift;
1808   # If $do_keep_deep_const this is heuristic only
1809   my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
1810   my $ignore_mods
1811     = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1812   if ($do_keep_deep_const) {    # Keep different compiled /RExen/o separately!
1813     $type =~ s/$ignore_mods//go;
1814   }
1815   else {
1816     $type =~ s/$ignore_mods//go;
1817   }
1818   $type =~ s/([^\s\w])/ $1 /g;
1819   $type =~ s/\s+$//;
1820   $type =~ s/^\s+//;
1821   $type =~ s/\s+/ /g;
1822   $type =~ s/\* (?=\*)/*/g;
1823   $type =~ s/\. \. \./.../g;
1824   $type =~ s/ ,/,/g;
1825   $types_seen{$type}++
1826     unless $type eq '...' or $type eq 'void' or $std_types{$type};
1827   $type;
1828 }
1829
1830 my $need_opaque;
1831
1832 sub assign_typemap_entry {
1833   my $type = shift;
1834   my $otype = $type;
1835   my $entry;
1836   if ($tmask and $type =~ /$tmask/) {
1837     print "Type $type matches -o mask\n" if $opt_d;
1838     $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1839   }
1840   elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1841     $type = normalize_type $type;
1842     print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1843     $entry = assign_typemap_entry($type);
1844   }
1845   # XXX good do better if our UV happens to be long long
1846   return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/;
1847   $entry ||= $typemap{$otype}
1848     || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1849   $typemap{$otype} = $entry;
1850   $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1851   return $entry;
1852 }
1853
1854 for (@vdecls) {
1855   print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
1856 }
1857
1858 if ($opt_x) {
1859   for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1860   if ($opt_a) {
1861     while (my($name, $struct) = each %structs) {
1862       print_accessors(\*XS, $name, $struct);
1863     }
1864   }
1865 }
1866
1867 close XS;
1868
1869 if (%types_seen) {
1870   my $type;
1871   warn "Writing $ext$modpname/typemap\n";
1872   open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1873
1874   for $type (sort keys %types_seen) {
1875     my $entry = assign_typemap_entry $type;
1876     print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
1877   }
1878
1879   print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1880 #############################################################################
1881 INPUT
1882 T_OPAQUE_STRUCT
1883         if (sv_derived_from($arg, \"${ntype}\")) {
1884             STRLEN len;
1885             char  *s = SvPV((SV*)SvRV($arg), len);
1886
1887             if (len != sizeof($var))
1888                 croak(\"Size %d of packed data != expected %d\",
1889                         len, sizeof($var));
1890             $var = *($type *)s;
1891         }
1892         else
1893             croak(\"$var is not of type ${ntype}\")
1894 #############################################################################
1895 OUTPUT
1896 T_OPAQUE_STRUCT
1897         sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1898 EOP
1899
1900   close TM or die "Cannot close typemap file for write: $!";
1901 }
1902
1903 } # if( ! $opt_X )
1904
1905 warn "Writing $ext$modpname/Makefile.PL\n";
1906 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
1907
1908 my $prereq_pm = '';
1909
1910 if ( $compat_version < 5.006002 and $new_test )
1911 {
1912   $prereq_pm .= q%'Test::More'  =>  0, %;
1913 }
1914 elsif ( $compat_version < 5.006002 )
1915 {
1916   $prereq_pm .= q%'Test'        =>  0, %;
1917 }
1918
1919 if ( $compat_version < 5.006 and !$opt_X and $use_xsloader)
1920 {
1921   $prereq_pm .= q%'XSLoader'    =>  0, %;
1922 }
1923
1924 print PL <<"END";
1925 use $compat_version;
1926 use ExtUtils::MakeMaker;
1927 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
1928 # the contents of the Makefile that is written.
1929 WriteMakefile(
1930     NAME              => '$module',
1931     VERSION_FROM      => '$modpmname', # finds \$VERSION
1932     PREREQ_PM         => {$prereq_pm}, # e.g., Module::Name => 1.1
1933     (\$] >= 5.005 ?     ## Add these new keywords supported since 5.005
1934       (ABSTRACT_FROM  => '$modpmname', # retrieve abstract from module
1935        AUTHOR         => '$author <$email>') : ()),
1936 END
1937 if (!$opt_X) { # print C stuff, unless XS is disabled
1938   $opt_F = '' unless defined $opt_F;
1939   my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
1940   my $Ihelp = ($I ? '-I. ' : '');
1941   my $Icomment = ($I ? '' : <<EOC);
1942         # Insert -I. if you add *.h files later:
1943 EOC
1944
1945   print PL <<END;
1946     LIBS              => ['$extralibs'], # e.g., '-lm'
1947     DEFINE            => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1948 $Icomment    INC               => '$I', # e.g., '${Ihelp}-I/usr/include/other'
1949 END
1950
1951   my $C = grep {$_ ne "$modfname.c"}
1952     (glob '*.c'), (glob '*.cc'), (glob '*.C');
1953   my $Cpre = ($C ? '' : '# ');
1954   my $Ccomment = ($C ? '' : <<EOC);
1955         # Un-comment this if you add C files to link with later:
1956 EOC
1957
1958   print PL <<END;
1959 $Ccomment    ${Cpre}OBJECT            => '\$(O_FILES)', # link all the C files too
1960 END
1961 } # ' # Grr
1962 print PL ");\n";
1963 if (!$opt_c) {
1964   my $generate_code =
1965     WriteMakefileSnippet ( C_FILE =>       $constscfname,
1966                            XS_FILE =>      $constsxsfname,
1967                            DEFAULT_TYPE => $opt_t,
1968                            NAME =>         $module,
1969                            NAMES =>        \@const_specs,
1970                  );
1971   print PL <<"END";
1972 if  (eval {require ExtUtils::Constant; 1}) {
1973   # If you edit these definitions to change the constants used by this module,
1974   # you will need to use the generated $constscfname and $constsxsfname
1975   # files to replace their "fallback" counterparts before distributing your
1976   # changes.
1977 $generate_code
1978 }
1979 else {
1980   use File::Copy;
1981   use File::Spec;
1982   foreach my \$file ('$constscfname', '$constsxsfname') {
1983     my \$fallback = File::Spec->catfile('$fallbackdirname', \$file);
1984     copy (\$fallback, \$file) or die "Can't copy \$fallback to \$file: \$!";
1985   }
1986 }
1987 END
1988
1989   eval $generate_code;
1990   if ($@) {
1991     warn <<"EOM";
1992 Attempting to test constant code in $ext$modpname/Makefile.PL:
1993 $generate_code
1994 __END__
1995 gave unexpected error $@
1996 Please report the circumstances of this bug in h2xs version $H2XS_VERSION
1997 using the perlbug script.
1998 EOM
1999   } else {
2000     my $fail;
2001
2002     foreach my $file ($constscfname, $constsxsfname) {
2003       my $fallback = File::Spec->catfile($fallbackdirname, $file);
2004       if (compare($file, $fallback)) {
2005         warn << "EOM";
2006 Files "$ext$modpname/$fallbackdirname/$file" and "$ext$modpname/$file" differ.
2007 EOM
2008         $fail++;
2009       }
2010     }
2011     if ($fail) {
2012       warn fill ('','', <<"EOM") . "\n";
2013 It appears that the code in $ext$modpname/Makefile.PL does not autogenerate
2014 the files $ext$modpname/$constscfname and $ext$modpname/$constsxsfname
2015 correctly.
2016
2017 Please report the circumstances of this bug in h2xs version $H2XS_VERSION
2018 using the perlbug script.
2019 EOM
2020     } else {
2021       unlink $constscfname, $constsxsfname;
2022     }
2023   }
2024 }
2025 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
2026
2027 # Create a simple README since this is a CPAN requirement
2028 # and it doesn't hurt to have one
2029 warn "Writing $ext$modpname/README\n";
2030 open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
2031 my $thisyear = (gmtime)[5] + 1900;
2032 my $rmhead = "$modpname version $TEMPLATE_VERSION";
2033 my $rmheadeq = "=" x length($rmhead);
2034
2035 my $rm_prereq;
2036
2037 if ( $compat_version < 5.006002 and $new_test )
2038 {
2039   $rm_prereq = 'Test::More';
2040 }
2041 elsif ( $compat_version < 5.006002 )
2042 {
2043   $rm_prereq = 'Test';
2044 }
2045 else
2046 {
2047   $rm_prereq = 'blah blah blah';
2048 }
2049
2050 print RM <<_RMEND_;
2051 $rmhead
2052 $rmheadeq
2053
2054 The README is used to introduce the module and provide instructions on
2055 how to install the module, any machine dependencies it may have (for
2056 example C compilers and installed libraries) and any other information
2057 that should be provided before the module is installed.
2058
2059 A README file is required for CPAN modules since CPAN extracts the
2060 README file from a module distribution so that people browsing the
2061 archive can use it get an idea of the modules uses. It is usually a
2062 good idea to provide version information here so that people can
2063 decide whether fixes for the module are worth downloading.
2064
2065 INSTALLATION
2066
2067 To install this module type the following:
2068
2069    perl Makefile.PL
2070    make
2071    make test
2072    make install
2073
2074 DEPENDENCIES
2075
2076 This module requires these other modules and libraries:
2077
2078   $rm_prereq
2079
2080 COPYRIGHT AND LICENCE
2081
2082 Put the correct copyright and licence information here.
2083
2084 $licence
2085
2086 _RMEND_
2087 close(RM) || die "Can't close $ext$modpname/README: $!\n";
2088
2089 my $testdir  = "t";
2090 my $testfile = "$testdir/$modpname.t";
2091 unless (-d "$testdir") {
2092   mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n";
2093 }
2094 warn "Writing $ext$modpname/$testfile\n";
2095 my $tests = @const_names ? 2 : 1;
2096
2097 open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n";
2098
2099 print EX <<_END_;
2100 # Before 'make install' is performed this script should be runnable with
2101 # 'make test'. After 'make install' it should work as 'perl $modpname.t'
2102
2103 #########################
2104
2105 # change 'tests => $tests' to 'tests => last_test_to_print';
2106
2107 use strict;
2108 use warnings;
2109
2110 _END_
2111
2112 my $test_mod = 'Test::More';
2113
2114 if ( $old_test or ($compat_version < 5.006002 and not $new_test ))
2115 {
2116   my $test_mod = 'Test';
2117
2118   print EX <<_END_;
2119 use Test;
2120 BEGIN { plan tests => $tests };
2121 use $module;
2122 ok(1); # If we made it this far, we're ok.
2123
2124 _END_
2125
2126    if (@const_names) {
2127      my $const_names = join " ", @const_names;
2128      print EX <<'_END_';
2129
2130 my $fail;
2131 foreach my $constname (qw(
2132 _END_
2133
2134      print EX wrap ("\t", "\t", $const_names);
2135      print EX (")) {\n");
2136
2137      print EX <<_END_;
2138   next if (eval "my \\\$a = \$constname; 1");
2139   if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
2140     print "# pass: \$\@";
2141   } else {
2142     print "# fail: \$\@";
2143     \$fail = 1;
2144   }
2145 }
2146 if (\$fail) {
2147   print "not ok 2\\n";
2148 } else {
2149   print "ok 2\\n";
2150 }
2151
2152 _END_
2153   }
2154 }
2155 else
2156 {
2157   print EX <<_END_;
2158 use Test::More tests => $tests;
2159 BEGIN { use_ok('$module') };
2160
2161 _END_
2162
2163    if (@const_names) {
2164      my $const_names = join " ", @const_names;
2165      print EX <<'_END_';
2166
2167 my $fail = 0;
2168 foreach my $constname (qw(
2169 _END_
2170
2171      print EX wrap ("\t", "\t", $const_names);
2172      print EX (")) {\n");
2173
2174      print EX <<_END_;
2175   next if (eval "my \\\$a = \$constname; 1");
2176   if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
2177     print "# pass: \$\@";
2178   } else {
2179     print "# fail: \$\@";
2180     \$fail = 1;
2181   }
2182
2183 }
2184
2185 ok( \$fail == 0 , 'Constants' );
2186 _END_
2187   }
2188 }
2189
2190 print EX <<_END_;
2191 #########################
2192
2193 # Insert your test code below, the $test_mod module is use()ed here so read
2194 # its man page ( perldoc $test_mod ) for help writing this test script.
2195
2196 _END_
2197
2198 close(EX) || die "Can't close $ext$modpname/$testfile: $!\n";
2199
2200 unless ($opt_C) {
2201   warn "Writing $ext$modpname/Changes\n";
2202   $" = ' ';
2203   open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
2204   @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
2205   print EX <<EOP;
2206 Revision history for Perl extension $module.
2207
2208 $TEMPLATE_VERSION  @{[scalar localtime]}
2209 \t- original version; created by h2xs $H2XS_VERSION with options
2210 \t\t@ARGS
2211
2212 EOP
2213   close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
2214 }
2215
2216 warn "Writing $ext$modpname/MANIFEST\n";
2217 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
2218 my @files = grep { -f } (<*>, <t/*>, <$fallbackdirname/*>, <$modpmdir/*>);
2219 if (!@files) {
2220   eval {opendir(D,'.');};
2221   unless ($@) { @files = readdir(D); closedir(D); }
2222 }
2223 if (!@files) { @files = map {chomp && $_} `ls`; }
2224 if ($^O eq 'VMS') {
2225   foreach (@files) {
2226     # Clip trailing '.' for portability -- non-VMS OSs don't expect it
2227     s%\.$%%;
2228     # Fix up for case-sensitive file systems
2229     s/$modfname/$modfname/i && next;
2230     $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
2231     $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
2232   }
2233 }
2234 print MANI join("\n",@files), "\n";
2235 close MANI;
2236 !NO!SUBS!
2237
2238 close OUT or die "Can't close $file: $!";
2239 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
2240 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
2241 chdir $origdir;