bin/h2xs

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