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