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