utils/h2xs.PL

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