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