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 Config;
 692     use File::Spec;
 693     my @paths;
 694     my $pre_sub_tri_graphs = 1;
 695     if ($^O eq 'VMS') {  # Consider overrides of default location
 696       # XXXX This is not equivalent to what the older version did:
 697       #         it was looking at $hadsys header-file per header-file...
 698       my($hadsys) = grep s!^sys/!!i , @path_h;
 699       @paths = qw( Sys$Library VAXC$Include );
 700       push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
 701       push @paths, qw( DECC$Library_Include DECC$System_Include );
 702     }
 703     else {
 704       @paths = (File::Spec->curdir(), $Config{usrinc},
 705                 (split ' ', $Config{locincpth}), '/usr/include');
 706     }
 707     foreach my $path_h (@path_h) {
 708         $name ||= $path_h;
 709     $module ||= do {
 710       $name =~ s/\.h$//;
 711       if ( $name !~ /::/ ) {
 712         $name =~ s#^.*/##;
 713         $name = "\u$name";
 714       }
 715       $name;
 716     };
 717
 718     if( $path_h =~ s#::#/#g && $opt_n ){
 719         warn "Nesting of headerfile ignored with -n\n";
 720     }
 721     $path_h .= ".h" unless $path_h =~ /\.h$/;
 722     my $fullpath = $path_h;
 723     $path_h =~ s/,.*$// if $opt_x;
 724     $fullpath{$path_h} = $fullpath;
 725
 726     # Minor trickery: we can't chdir() before we processed the headers
 727     # (so know the name of the extension), but the header may be in the
 728     # extension directory...
 729     my $tmp_path_h = $path_h;
 730     my $rel_path_h = $path_h;
 731     my @dirs = @paths;
 732     if (not -f $path_h) {
 733       my $found;
 734       for my $dir (@paths) {
 735         $found++, last
 736           if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
 737       }
 738       if ($found) {
 739         $rel_path_h = $path_h;
 740         $fullpath{$path_h} = $fullpath;
 741       } else {
 742         (my $epath = $module) =~ s,::,/,g;
 743         $epath = File::Spec->catdir('ext', $epath) if -d 'ext';
 744         $rel_path_h = File::Spec->catfile($epath, $tmp_path_h);
 745         $path_h = $tmp_path_h;  # Used during -x
 746         push @dirs, $epath;
 747       }
 748     }
 749
 750     if (!$opt_c) {
 751       die "Can't find $tmp_path_h in @dirs\n"
 752         if ( ! $opt_f && ! -f "$rel_path_h" );
 753       # Scan the header file (we should deal with nested header files)
 754       # Record the names of simple #define constants into const_names
 755             # Function prototypes are processed below.
 756       open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n";
 757     defines:
 758       while (<CH>) {
 759         if ($pre_sub_tri_graphs) {
 760             # Preprocess all tri-graphs
 761             # including things stuck in quoted string constants.
 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             s/\?\?>/}/g;                         # | ??>|  }|
 771         }
 772         if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) {
 773             my $def = $1;
 774             my $rest = $2;
 775             $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
 776             $rest =~ s/^\s+//;
 777             $rest =~ s/\s+$//;
 778             # Cannot do: (-1) and ((LHANDLE)3) are OK:
 779             #print("Skip non-wordy $def => $rest\n"),
 780             #  next defines if $rest =~ /[^\w\$]/;
 781             if ($rest =~ /"/) {
 782               print("Skip stringy $def => $rest\n") if $opt_d;
 783               next defines;
 784             }
 785             print "Matched $_ ($def)\n" if $opt_d;
 786             $seen_define{$def} = $rest;
 787             $_ = $def;
 788             next if /^_.*_h_*$/i; # special case, but for what?
 789             if (defined $opt_p) {
 790               if (!/^$opt_p(\d)/) {
 791                 ++$prefix{$_} if s/^$opt_p//;
 792               }
 793               else {
 794                 warn "can't remove $opt_p prefix from '$_'!\n";
 795               }
 796             }
 797             $prefixless{$def} = $_;
 798             if (!$fmask or /$fmask/) {
 799                 print "... Passes mask of -M.\n" if $opt_d and $fmask;
 800                 $const_names{$_}++;
 801             }
 802           }
 803       }
 804       close(CH);
 805     }
 806     }
 807 }
 808
 809 # Save current directory so that C::Scan can use it
 810 my $cwd = File::Spec->rel2abs( File::Spec->curdir );
 811
 812 my ($ext, $nested, @modparts, $modfname, $modpname, $constsfname);
 813
 814 $ext = chdir 'ext' ? 'ext/' : '';
 815
 816 if( $module =~ /::/ ){
 817         $nested = 1;
 818         @modparts = split(/::/,$module);
 819         $modfname = $modparts[-1];
 820         $modpname = join('/',@modparts);
 821 }
 822 else {
 823         $nested = 0;
 824         @modparts = ();
 825         $modfname = $modpname = $module;
 826 }
 827 # Don't trip up if someone calls their module 'constants'
 828 $constsfname = $modfname eq 'constants' ? 'constdefs' : 'constants';
 829
 830
 831 if ($opt_O) {
 832         warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
 833 }
 834 else {
 835         die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
 836 }
 837 if( $nested ){
 838         my $modpath = "";
 839         foreach (@modparts){
 840                 -d "$modpath$_" || mkdir("$modpath$_", 0777);
 841                 $modpath .= "$_/";
 842         }
 843 }
 844 -d "$modpname"   || mkdir($modpname, 0777);
 845 chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
 846
 847 my %types_seen;
 848 my %std_types;
 849 my $fdecls = [];
 850 my $fdecls_parsed = [];
 851 my $typedef_rex;
 852 my %typedefs_pre;
 853 my %known_fnames;
 854 my %structs;
 855
 856 my @fnames;
 857 my @fnames_no_prefix;
 858 my %vdecl_hash;
 859 my @vdecls;
 860
 861 if( ! $opt_X ){  # use XS, unless it was disabled
 862   unless ($skip_ppport) {
 863     require Devel::PPPort;
 864     warn "Writing $ext$modpname/ppport.h\n";
 865     Devel::PPPort::WriteFile('ppport.h')
 866         || die "Can't create $ext$modpname/ppport.h: $!\n";
 867   }
 868   open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
 869   if ($opt_x) {
 870     require Config;             # Run-time directive
 871     warn "Scanning typemaps...\n";
 872     get_typemap();
 873     my @td;
 874     my @good_td;
 875     my $addflags = $opt_F || '';
 876
 877     foreach my $filename (@path_h) {
 878       my $c;
 879       my $filter;
 880
 881       if ($fullpath{$filename} =~ /,/) {
 882         $filename = $`;
 883         $filter = $';
 884       }
 885       warn "Scanning $filename for functions...\n";
 886       my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X);
 887       $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
 888         'add_cppflags' => $addflags, 'c_styles' => \@styles;
 889       $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]);
 890
 891       push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
 892       push(@$fdecls, @{$c->get('fdecls')});
 893
 894       push @td, @{$c->get('typedefs_maybe')};
 895       if ($opt_a) {
 896         my $structs = $c->get('typedef_structs');
 897         @structs{keys %$structs} = values %$structs;
 898       }
 899
 900       if ($opt_m) {
 901         %vdecl_hash = %{ $c->get('vdecl_hash') };
 902         @vdecls = sort keys %vdecl_hash;
 903         for (local $_ = 0; $_ < @vdecls; ++$_) {
 904           my $var = $vdecls[$_];
 905           my($type, $post) = @{ $vdecl_hash{$var} };
 906           if (defined $post) {
 907             warn "Can't handle variable '$type $var $post', skipping.\n";
 908             splice @vdecls, $_, 1;
 909             redo;
 910           }
 911           $type = normalize_type($type);
 912           $vdecl_hash{$var} = $type;
 913         }
 914       }
 915
 916       unless ($tmask_all) {
 917         warn "Scanning $filename for typedefs...\n";
 918         my $td = $c->get('typedef_hash');
 919         # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
 920         my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
 921         push @good_td, @f_good_td;
 922         @typedefs_pre{@f_good_td}  = map $_->[0], @$td{@f_good_td};
 923       }
 924     }
 925     { local $" = '|';
 926       $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
 927     }
 928     %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
 929     if ($fmask) {
 930       my @good;
 931       for my $i (0..$#$fdecls_parsed) {
 932         next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
 933         push @good, $i;
 934         print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
 935           if $opt_d;
 936       }
 937       $fdecls = [@$fdecls[@good]];
 938       $fdecls_parsed = [@$fdecls_parsed[@good]];
 939     }
 940     @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
 941     # Sort declarations:
 942     {
 943       my %h = map( ($_->[1], $_), @$fdecls_parsed);
 944       $fdecls_parsed = [ @h{@fnames} ];
 945     }
 946     @fnames_no_prefix = @fnames;
 947     @fnames_no_prefix
 948       = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix
 949          if defined $opt_p;
 950     # Remove macros which expand to typedefs
 951     print "Typedefs are @td.\n" if $opt_d;
 952     my %td = map {($_, $_)} @td;
 953     # Add some other possible but meaningless values for macros
 954     for my $k (qw(char double float int long short unsigned signed void)) {
 955       $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
 956     }
 957     # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
 958     my $n = 0;
 959     my %bad_macs;
 960     while (keys %td > $n) {
 961       $n = keys %td;
 962       my ($k, $v);
 963       while (($k, $v) = each %seen_define) {
 964         # print("found '$k'=>'$v'\n"),
 965         $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
 966       }
 967     }
 968     # Now %bad_macs contains names of bad macros
 969     for my $k (keys %bad_macs) {
 970       delete $const_names{$prefixless{$k}};
 971       print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
 972     }
 973   }
 974 }
 975 my @const_names = sort keys %const_names;
 976
 977 open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
 978
 979 $" = "\n\t";
 980 warn "Writing $ext$modpname/$modfname.pm\n";
 981
 982 print PM <<"END";
 983 package $module;
 984
 985 use $compat_version;
 986 END
 987
 988 print PM <<"END" unless $skip_strict;
 989 use strict;
 990 END
 991
 992 print PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006;
 993
 994 unless( $opt_X || $opt_c || $opt_A ){
 995         # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
 996         # will want Carp.
 997         print PM <<'END';
 998 use Carp;
 999 END
1000 }
1001
1002 print PM <<'END' unless $skip_exporter;
1003
1004 require Exporter;
1005 END
1006
1007 my $use_Dyna = (not $opt_X and $compat_version < 5.006);
1008 print PM <<"END" if $use_Dyna;  # use DynaLoader, unless XS was disabled
1009 require DynaLoader;
1010 END
1011
1012
1013 # Are we using AutoLoader or not?
1014 unless ($skip_autoloader) { # no autoloader whatsoever.
1015         unless ($opt_c) { # we're doing the AUTOLOAD
1016                 print PM "use AutoLoader;\n";
1017         }
1018         else {
1019                 print PM "use AutoLoader qw(AUTOLOAD);\n"
1020         }
1021 }
1022
1023 if ( $compat_version < 5.006 ) {
1024     if ( $opt_X || $opt_c || $opt_A ) {
1025         if ($skip_exporter) {
1026           print PM 'use vars qw($VERSION @ISA);';
1027         } else {
1028           print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);';
1029         }
1030     } else {
1031         if ($skip_exporter) {
1032           print PM 'use vars qw($VERSION @ISA $AUTOLOAD);';
1033         } else {
1034           print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);';
1035         }
1036     }
1037 }
1038
1039 # Determine @ISA.
1040 my @modISA;
1041 push @modISA, 'Exporter'        unless $skip_exporter;
1042 push @modISA, 'DynaLoader'      if $use_Dyna;  # no XS
1043 my $myISA = "our \@ISA = qw(@modISA);";
1044 $myISA =~ s/^our // if $compat_version < 5.006;
1045
1046 print PM "\n$myISA\n\n";
1047
1048 my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
1049
1050 my $tmp='';
1051 $tmp .= <<"END" unless $skip_exporter;
1052 # Items to export into callers namespace by default. Note: do not export
1053 # names by default without a very good reason. Use EXPORT_OK instead.
1054 # Do not simply export all your public functions/methods/constants.
1055
1056 # This allows declaration       use $module ':all';
1057 # If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
1058 # will save memory.
1059 our %EXPORT_TAGS = ( 'all' => [ qw(
1060         @exported_names
1061 ) ] );
1062
1063 our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
1064
1065 our \@EXPORT = qw(
1066         @const_names
1067 );
1068
1069 END
1070
1071 $tmp .= <<"END";
1072 our \$VERSION = '$TEMPLATE_VERSION';
1073
1074 END
1075
1076 $tmp =~ s/^our //mg if $compat_version < 5.006;
1077 print PM $tmp;
1078
1079 if (@vdecls) {
1080     printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
1081 }
1082
1083
1084 print PM autoload ($module, $compat_version) unless $opt_c or $opt_X;
1085
1086 if( ! $opt_X ){ # print bootstrap, unless XS is disabled
1087   if ($use_Dyna) {
1088         print PM <<"END";
1089 bootstrap $module \$VERSION;
1090 END
1091   } else {
1092         print PM <<"END";
1093 require XSLoader;
1094 XSLoader::load('$module', \$VERSION);
1095 END
1096   }
1097 }
1098
1099 # tying the variables can happen only after bootstrap
1100 if (@vdecls) {
1101     printf PM <<END;
1102 {
1103 @{[ join "\n", map "    _tievar_$_(\$$_);", @vdecls ]}
1104 }
1105
1106 END
1107 }
1108
1109 my $after;
1110 if( $opt_P ){ # if POD is disabled
1111         $after = '__END__';
1112 }
1113 else {
1114         $after = '=cut';
1115 }
1116
1117 print PM <<"END";
1118
1119 # Preloaded methods go here.
1120 END
1121
1122 print PM <<"END" unless $opt_A;
1123
1124 # Autoload methods go after $after, and are processed by the autosplit program.
1125 END
1126
1127 print PM <<"END";
1128
1129 1;
1130 __END__
1131 END
1132
1133 my ($email,$author);
1134
1135 eval {
1136        my $username;
1137        ($username,$author) = (getpwuid($>))[0,6];
1138        if (defined $username && defined $author) {
1139            $author =~ s/,.*$//; # in case of sub fields
1140            my $domain = $Config{'mydomain'};
1141            $domain =~ s/^\.//;
1142            $email = "$username\@$domain";
1143        }
1144      };
1145
1146 $author ||= "A. U. Thor";
1147 $email  ||= 'a.u.thor@a.galaxy.far.far.away';
1148
1149 my $revhist = '';
1150 $revhist = <<EOT if $opt_C;
1151 #
1152 #=head1 HISTORY
1153 #
1154 #=over 8
1155 #
1156 #=item $TEMPLATE_VERSION
1157 #
1158 #Original version; created by h2xs $H2XS_VERSION with options
1159 #
1160 #  @ARGS
1161 #
1162 #=back
1163 #
1164 EOT
1165
1166 my $exp_doc = $skip_exporter ? '' : <<EOD;
1167 #
1168 #=head2 EXPORT
1169 #
1170 #None by default.
1171 #
1172 EOD
1173
1174 if (@const_names and not $opt_P) {
1175   $exp_doc .= <<EOD unless $skip_exporter;
1176 #=head2 Exportable constants
1177 #
1178 #  @{[join "\n  ", @const_names]}
1179 #
1180 EOD
1181 }
1182
1183 if (defined $fdecls and @$fdecls and not $opt_P) {
1184   $exp_doc .= <<EOD unless $skip_exporter;
1185 #=head2 Exportable functions
1186 #
1187 EOD
1188
1189 #  $exp_doc .= <<EOD if $opt_p;
1190 #When accessing these functions from Perl, prefix C<$opt_p> should be removed.
1191 #
1192 #EOD
1193   $exp_doc .= <<EOD unless $skip_exporter;
1194 #  @{[join "\n  ", @known_fnames{@fnames}]}
1195 #
1196 EOD
1197 }
1198
1199 my $meth_doc = '';
1200
1201 if ($opt_x && $opt_a) {
1202   my($name, $struct);
1203   $meth_doc .= accessor_docs($name, $struct)
1204     while ($name, $struct) = each %structs;
1205 }
1206
1207 my $pod = <<"END" unless $opt_P;
1208 ## Below is stub documentation for your module. You'd better edit it!
1209 #
1210 #=head1 NAME
1211 #
1212 #$module - Perl extension for blah blah blah
1213 #
1214 #=head1 SYNOPSIS
1215 #
1216 #  use $module;
1217 #  blah blah blah
1218 #
1219 #=head1 ABSTRACT
1220 #
1221 #  This should be the abstract for $module.
1222 #  The abstract is used when making PPD (Perl Package Description) files.
1223 #  If you don't want an ABSTRACT you should also edit Makefile.PL to
1224 #  remove the ABSTRACT_FROM option.
1225 #
1226 #=head1 DESCRIPTION
1227 #
1228 #Stub documentation for $module, created by h2xs. It looks like the
1229 #author of the extension was negligent enough to leave the stub
1230 #unedited.
1231 #
1232 #Blah blah blah.
1233 $exp_doc$meth_doc$revhist
1234 #
1235 #=head1 SEE ALSO
1236 #
1237 #Mention other useful documentation such as the documentation of
1238 #related modules or operating system documentation (such as man pages
1239 #in UNIX), or any relevant external documentation such as RFCs or
1240 #standards.
1241 #
1242 #If you have a mailing list set up for your module, mention it here.
1243 #
1244 #If you have a web site set up for your module, mention it here.
1245 #
1246 #=head1 AUTHOR
1247 #
1248 #$author, E<lt>${email}E<gt>
1249 #
1250 #=head1 COPYRIGHT AND LICENSE
1251 #
1252 #Copyright ${\(1900 + (localtime) [5])} by $author
1253 #
1254 #This library is free software; you can redistribute it and/or modify
1255 #it under the same terms as Perl itself.
1256 #
1257 #=cut
1258 END
1259
1260 $pod =~ s/^\#//gm unless $opt_P;
1261 print PM $pod unless $opt_P;
1262
1263 close PM;
1264
1265
1266 if( ! $opt_X ){ # print XS, unless it is disabled
1267 warn "Writing $ext$modpname/$modfname.xs\n";
1268
1269 print XS <<"END";
1270 #include "EXTERN.h"
1271 #include "perl.h"
1272 #include "XSUB.h"
1273
1274 END
1275
1276 print XS <<"END" unless $skip_ppport;
1277 #include "ppport.h"
1278
1279 END
1280
1281 if( @path_h ){
1282     foreach my $path_h (@path_h_ini) {
1283         my($h) = $path_h;
1284         $h =~ s#^/usr/include/##;
1285         if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
1286         print XS qq{#include <$h>\n};
1287     }
1288     print XS "\n";
1289 }
1290
1291 print XS <<"END" if $opt_g;
1292
1293 /* Global Data */
1294
1295 #define MY_CXT_KEY "${module}::_guts" XS_VERSION
1296
1297 typedef struct {
1298     /* Put Global Data in here */
1299     int dummy;          /* you can access this elsewhere as MY_CXT.dummy */
1300 } my_cxt_t;
1301
1302 START_MY_CXT
1303
1304 END
1305
1306 my %pointer_typedefs;
1307 my %struct_typedefs;
1308
1309 sub td_is_pointer {
1310   my $type = shift;
1311   my $out = $pointer_typedefs{$type};
1312   return $out if defined $out;
1313   my $otype = $type;
1314   $out = ($type =~ /\*$/);
1315   # This converts only the guys which do not have trailing part in the typedef
1316   if (not $out
1317       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1318     $type = normalize_type($type);
1319     print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1320       if $opt_d;
1321     $out = td_is_pointer($type);
1322   }
1323   return ($pointer_typedefs{$otype} = $out);
1324 }
1325
1326 sub td_is_struct {
1327   my $type = shift;
1328   my $out = $struct_typedefs{$type};
1329   return $out if defined $out;
1330   my $otype = $type;
1331   $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
1332   # This converts only the guys which do not have trailing part in the typedef
1333   if (not $out
1334       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1335     $type = normalize_type($type);
1336     print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
1337       if $opt_d;
1338     $out = td_is_struct($type);
1339   }
1340   return ($struct_typedefs{$otype} = $out);
1341 }
1342
1343 print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1344
1345 if( ! $opt_c ) {
1346   # We write the "sample" files used when this module is built by perl without
1347   # ExtUtils::Constant.
1348   # h2xs will later check that these are the same as those generated by the
1349   # code embedded into Makefile.PL
1350   warn "Writing $ext$modpname/fallback.c\n";
1351   warn "Writing $ext$modpname/fallback.xs\n";
1352   WriteConstants ( C_FILE =>       "fallback.c",
1353                    XS_FILE =>      "fallback.xs",
1354                    DEFAULT_TYPE => $opt_t,
1355                    NAME =>         $module,
1356                    NAMES =>        \@const_names,
1357                  );
1358   print XS "#include \"$constsfname.c\"\n";
1359 }
1360
1361
1362 my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
1363
1364 # Now switch from C to XS by issuing the first MODULE declaration:
1365 print XS <<"END";
1366
1367 MODULE = $module                PACKAGE = $module               $prefix
1368
1369 END
1370
1371 # If a constant() function was #included then output a corresponding
1372 # XS declaration:
1373 print XS "INCLUDE: $constsfname.xs\n" unless $opt_c;
1374
1375 print XS <<"END" if $opt_g;
1376
1377 BOOT:
1378 {
1379     MY_CXT_INIT;
1380     /* If any of the fields in the my_cxt_t struct need
1381        to be initialised, do it here.
1382      */
1383 }
1384
1385 END
1386
1387 foreach (sort keys %const_xsub) {
1388     print XS <<"END";
1389 char *
1390 $_()
1391
1392     CODE:
1393 #ifdef $_
1394         RETVAL = $_;
1395 #else
1396         croak("Your vendor has not defined the $module macro $_");
1397 #endif
1398
1399     OUTPUT:
1400         RETVAL
1401
1402 END
1403 }
1404
1405 my %seen_decl;
1406 my %typemap;
1407
1408 sub print_decl {
1409   my $fh = shift;
1410   my $decl = shift;
1411   my ($type, $name, $args) = @$decl;
1412   return if $seen_decl{$name}++; # Need to do the same for docs as well?
1413
1414   my @argnames = map {$_->[1]} @$args;
1415   my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
1416   if ($opt_k) {
1417     s/^\s*const\b\s*// for @argtypes;
1418   }
1419   my @argarrays = map { $_->[4] || '' } @$args;
1420   my $numargs = @$args;
1421   if ($numargs and $argtypes[-1] eq '...') {
1422     $numargs--;
1423     $argnames[-1] = '...';
1424   }
1425   local $" = ', ';
1426   $type = normalize_type($type, 1);
1427
1428   print $fh <<"EOP";
1429
1430 $type
1431 $name(@argnames)
1432 EOP
1433
1434   for my $arg (0 .. $numargs - 1) {
1435     print $fh <<"EOP";
1436         $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
1437 EOP
1438   }
1439 }
1440
1441 sub print_tievar_subs {
1442   my($fh, $name, $type) = @_;
1443   print $fh <<END;
1444 I32
1445 _get_$name(IV index, SV *sv) {
1446     dSP;
1447     PUSHMARK(SP);
1448     XPUSHs(sv);
1449     PUTBACK;
1450     (void)call_pv("$module\::_get_$name", G_DISCARD);
1451     return (I32)0;
1452 }
1453
1454 I32
1455 _set_$name(IV index, SV *sv) {
1456     dSP;
1457     PUSHMARK(SP);
1458     XPUSHs(sv);
1459     PUTBACK;
1460     (void)call_pv("$module\::_set_$name", G_DISCARD);
1461     return (I32)0;
1462 }
1463
1464 END
1465 }
1466
1467 sub print_tievar_xsubs {
1468   my($fh, $name, $type) = @_;
1469   print $fh <<END;
1470 void
1471 _tievar_$name(sv)
1472         SV* sv
1473     PREINIT:
1474         struct ufuncs uf;
1475     CODE:
1476         uf.uf_val = &_get_$name;
1477         uf.uf_set = &_set_$name;
1478         uf.uf_index = (IV)&_get_$name;
1479         sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1480
1481 void
1482 _get_$name(THIS)
1483         $type THIS = NO_INIT
1484     CODE:
1485         THIS = $name;
1486     OUTPUT:
1487         SETMAGIC: DISABLE
1488         THIS
1489
1490 void
1491 _set_$name(THIS)
1492         $type THIS
1493     CODE:
1494         $name = THIS;
1495
1496 END
1497 }
1498
1499 sub print_accessors {
1500   my($fh, $name, $struct) = @_;
1501   return unless defined $struct && $name !~ /\s|_ANON/;
1502   $name = normalize_type($name);
1503   my $ptrname = normalize_type("$name *");
1504   print $fh <<"EOF";
1505
1506 MODULE = $module                PACKAGE = ${name}               $prefix
1507
1508 $name *
1509 _to_ptr(THIS)
1510         $name THIS = NO_INIT
1511     PROTOTYPE: \$
1512     CODE:
1513         if (sv_derived_from(ST(0), "$name")) {
1514             STRLEN len;
1515             char *s = SvPV((SV*)SvRV(ST(0)), len);
1516             if (len != sizeof(THIS))
1517                 croak("Size \%d of packed data != expected \%d",
1518                         len, sizeof(THIS));
1519             RETVAL = ($name *)s;
1520         }
1521         else
1522             croak("THIS is not of type $name");
1523     OUTPUT:
1524         RETVAL
1525
1526 $name
1527 new(CLASS)
1528         char *CLASS = NO_INIT
1529     PROTOTYPE: \$
1530     CODE:
1531         Zero((void*)&RETVAL, sizeof(RETVAL), char);
1532     OUTPUT:
1533         RETVAL
1534
1535 MODULE = $module                PACKAGE = ${name}Ptr            $prefix
1536
1537 EOF
1538   my @items = @$struct;
1539   while (@items) {
1540     my $item = shift @items;
1541     if ($item->[0] =~ /_ANON/) {
1542       if (defined $item->[2]) {
1543         push @items, map [
1544           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1545         ], @{ $structs{$item->[0]} };
1546       } else {
1547         push @items, @{ $structs{$item->[0]} };
1548       }
1549     } else {
1550       my $type = normalize_type($item->[0]);
1551       my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
1552       print $fh <<"EOF";
1553 $ttype
1554 $item->[2](THIS, __value = NO_INIT)
1555         $ptrname THIS
1556         $type __value
1557     PROTOTYPE: \$;\$
1558     CODE:
1559         if (items > 1)
1560             THIS->$item->[-1] = __value;
1561         RETVAL = @{[
1562             $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1563         ]};
1564     OUTPUT:
1565         RETVAL
1566
1567 EOF
1568     }
1569   }
1570 }
1571
1572 sub accessor_docs {
1573   my($name, $struct) = @_;
1574   return unless defined $struct && $name !~ /\s|_ANON/;
1575   $name = normalize_type($name);
1576   my $ptrname = $name . 'Ptr';
1577   my @items = @$struct;
1578   my @list;
1579   while (@items) {
1580     my $item = shift @items;
1581     if ($item->[0] =~ /_ANON/) {
1582       if (defined $item->[2]) {
1583         push @items, map [
1584           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1585         ], @{ $structs{$item->[0]} };
1586       } else {
1587         push @items, @{ $structs{$item->[0]} };
1588       }
1589     } else {
1590       push @list, $item->[2];
1591     }
1592   }
1593   my $methods = (join '(...)>, C<', @list) . '(...)';
1594
1595   my $pod = <<"EOF";
1596 #
1597 #=head2 Object and class methods for C<$name>/C<$ptrname>
1598 #
1599 #The principal Perl representation of a C object of type C<$name> is an
1600 #object of class C<$ptrname> which is a reference to an integer
1601 #representation of a C pointer.  To create such an object, one may use
1602 #a combination
1603 #
1604 #  my \$buffer = $name->new();
1605 #  my \$obj = \$buffer->_to_ptr();
1606 #
1607 #This exersizes the following two methods, and an additional class
1608 #C<$name>, the internal representation of which is a reference to a
1609 #packed string with the C structure.  Keep in mind that \$buffer should
1610 #better survive longer than \$obj.
1611 #
1612 #=over
1613 #
1614 #=item C<\$object_of_type_$name-E<gt>_to_ptr()>
1615 #
1616 #Converts an object of type C<$name> to an object of type C<$ptrname>.
1617 #
1618 #=item C<$name-E<gt>new()>
1619 #
1620 #Creates an empty object of type C<$name>.  The corresponding packed
1621 #string is zeroed out.
1622 #
1623 #=item C<$methods>
1624 #
1625 #return the current value of the corresponding element if called
1626 #without additional arguments.  Set the element to the supplied value
1627 #(and return the new value) if called with an additional argument.
1628 #
1629 #Applicable to objects of type C<$ptrname>.
1630 #
1631 #=back
1632 #
1633 EOF
1634   $pod =~ s/^\#//gm;
1635   return $pod;
1636 }
1637
1638 # Should be called before any actual call to normalize_type().
1639 sub get_typemap {
1640   # We do not want to read ./typemap by obvios reasons.
1641   my @tm =  qw(../../../typemap ../../typemap ../typemap);
1642   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
1643   unshift @tm, $stdtypemap;
1644   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
1645
1646   # Start with useful default values
1647   $typemap{float} = 'T_NV';
1648
1649   foreach my $typemap (@tm) {
1650     next unless -e $typemap ;
1651     # skip directories, binary files etc.
1652     warn " Scanning $typemap\n";
1653     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1654       unless -T $typemap ;
1655     open(TYPEMAP, $typemap)
1656       or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1657     my $mode = 'Typemap';
1658     while (<TYPEMAP>) {
1659       next if /^\s*\#/;
1660       if (/^INPUT\s*$/)   { $mode = 'Input'; next; }
1661       elsif (/^OUTPUT\s*$/)  { $mode = 'Output'; next; }
1662       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1663       elsif ($mode eq 'Typemap') {
1664         next if /^\s*($|\#)/ ;
1665         my ($type, $image);
1666         if ( ($type, $image) =
1667              /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1668              # This may reference undefined functions:
1669              and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
1670           $typemap{normalize_type($type)} = $image;
1671         }
1672       }
1673     }
1674     close(TYPEMAP) or die "Cannot close $typemap: $!";
1675   }
1676   %std_types = %types_seen;
1677   %types_seen = ();
1678 }
1679
1680
1681 sub normalize_type {            # Second arg: do not strip const's before \*
1682   my $type = shift;
1683   my $do_keep_deep_const = shift;
1684   # If $do_keep_deep_const this is heuristical only
1685   my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
1686   my $ignore_mods
1687     = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1688   if ($do_keep_deep_const) {    # Keep different compiled /RExen/o separately!
1689     $type =~ s/$ignore_mods//go;
1690   }
1691   else {
1692     $type =~ s/$ignore_mods//go;
1693   }
1694   $type =~ s/([^\s\w])/ $1 /g;
1695   $type =~ s/\s+$//;
1696   $type =~ s/^\s+//;
1697   $type =~ s/\s+/ /g;
1698   $type =~ s/\* (?=\*)/*/g;
1699   $type =~ s/\. \. \./.../g;
1700   $type =~ s/ ,/,/g;
1701   $types_seen{$type}++
1702     unless $type eq '...' or $type eq 'void' or $std_types{$type};
1703   $type;
1704 }
1705
1706 my $need_opaque;
1707
1708 sub assign_typemap_entry {
1709   my $type = shift;
1710   my $otype = $type;
1711   my $entry;
1712   if ($tmask and $type =~ /$tmask/) {
1713     print "Type $type matches -o mask\n" if $opt_d;
1714     $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1715   }
1716   elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1717     $type = normalize_type $type;
1718     print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1719     $entry = assign_typemap_entry($type);
1720   }
1721   # XXX good do better if our UV happens to be long long
1722   return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/;
1723   $entry ||= $typemap{$otype}
1724     || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1725   $typemap{$otype} = $entry;
1726   $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1727   return $entry;
1728 }
1729
1730 for (@vdecls) {
1731   print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
1732 }
1733
1734 if ($opt_x) {
1735   for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1736   if ($opt_a) {
1737     while (my($name, $struct) = each %structs) {
1738       print_accessors(\*XS, $name, $struct);
1739     }
1740   }
1741 }
1742
1743 close XS;
1744
1745 if (%types_seen) {
1746   my $type;
1747   warn "Writing $ext$modpname/typemap\n";
1748   open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1749
1750   for $type (sort keys %types_seen) {
1751     my $entry = assign_typemap_entry $type;
1752     print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
1753   }
1754
1755   print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1756 #############################################################################
1757 INPUT
1758 T_OPAQUE_STRUCT
1759         if (sv_derived_from($arg, \"${ntype}\")) {
1760             STRLEN len;
1761             char  *s = SvPV((SV*)SvRV($arg), len);
1762
1763             if (len != sizeof($var))
1764                 croak(\"Size %d of packed data != expected %d\",
1765                         len, sizeof($var));
1766             $var = *($type *)s;
1767         }
1768         else
1769             croak(\"$var is not of type ${ntype}\")
1770 #############################################################################
1771 OUTPUT
1772 T_OPAQUE_STRUCT
1773         sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1774 EOP
1775
1776   close TM or die "Cannot close typemap file for write: $!";
1777 }
1778
1779 } # if( ! $opt_X )
1780
1781 warn "Writing $ext$modpname/Makefile.PL\n";
1782 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
1783
1784 my $prereq_pm;
1785
1786 if ( $compat_version < 5.00702 and $new_test )
1787 {
1788   $prereq_pm = q%'Test::More'  =>  0%;
1789 }
1790 else
1791 {
1792   $prereq_pm = '';
1793 }
1794
1795 print PL <<"END";
1796 use $compat_version;
1797 use ExtUtils::MakeMaker;
1798 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
1799 # the contents of the Makefile that is written.
1800 WriteMakefile(
1801     'NAME'              => '$module',
1802     'VERSION_FROM'      => '$modfname.pm', # finds \$VERSION
1803     'PREREQ_PM'         => {$prereq_pm}, # e.g., Module::Name => 1.1
1804     (\$] >= 5.005 ?    ## Add these new keywords supported since 5.005
1805       (ABSTRACT_FROM => '$modfname.pm', # retrieve abstract from module
1806        AUTHOR     => '$author <$email>') : ()),
1807 END
1808 if (!$opt_X) { # print C stuff, unless XS is disabled
1809   $opt_F = '' unless defined $opt_F;
1810   my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
1811   my $Ihelp = ($I ? '-I. ' : '');
1812   my $Icomment = ($I ? '' : <<EOC);
1813         # Insert -I. if you add *.h files later:
1814 EOC
1815
1816   print PL <<END;
1817     'LIBS'              => ['$extralibs'], # e.g., '-lm'
1818     'DEFINE'            => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1819 $Icomment    'INC'              => '$I', # e.g., '${Ihelp}-I/usr/include/other'
1820 END
1821
1822   if (!$opt_c) {
1823     print PL <<"END";
1824     # Without this the constants xs files are spotted, and cause rules to be
1825     # added to delete the similarly names C files, which isn't what we want.
1826     'XS'                => {'$modfname.xs' => '$modfname.c'},
1827     realclean           => {FILES => '$constsfname.c $constsfname.xs'},
1828 END
1829   }
1830
1831   my $C = grep {$_ ne "$modfname.c" && $_ ne "fallback.c"}
1832     (glob '*.c'), (glob '*.cc'), (glob '*.C');
1833   my $Cpre = ($C ? '' : '# ');
1834   my $Ccomment = ($C ? '' : <<EOC);
1835         # Un-comment this if you add C files to link with later:
1836 EOC
1837
1838   print PL <<END;
1839 $Ccomment    $Cpre\'OBJECT'             => '\$(O_FILES)', # link all the C files too
1840 END
1841 } # ' # Grr
1842 print PL ");\n";
1843 if (!$opt_c) {
1844   my $generate_code =
1845     WriteMakefileSnippet ( C_FILE =>       "$constsfname.c",
1846                            XS_FILE =>      "$constsfname.xs",
1847                            DEFAULT_TYPE => $opt_t,
1848                            NAME =>         $module,
1849                            NAMES =>        \@const_names,
1850                  );
1851   print PL <<"END";
1852 if  (eval {require ExtUtils::Constant; 1}) {
1853   # If you edit these definitions to change the constants used by this module,
1854   # you will need to use the generated $constsfname.c and $constsfname.xs
1855   # files to replace their "fallback" counterparts before distributing your
1856   # changes.
1857 $generate_code
1858 }
1859 else {
1860   use File::Copy;
1861   copy ('fallback.c', '$constsfname.c')
1862     or die "Can't copy fallback.c to $constsfname.c: \$!";
1863   copy ('fallback.xs', '$constsfname.xs')
1864     or die "Can't copy fallback.xs to $constsfname.xs: \$!";
1865 }
1866 END
1867
1868   eval $generate_code;
1869   if ($@) {
1870     warn <<"EOM";
1871 Attempting to test constant code in $ext$modpname/Makefile.PL:
1872 $generate_code
1873 __END__
1874 gave unexpected error $@
1875 Please report the circumstances of this bug in h2xs version $H2XS_VERSION
1876 using the perlbug script.
1877 EOM
1878   } else {
1879     my $fail;
1880
1881     foreach ('c', 'xs') {
1882       if (compare("fallback.$_", "$constsfname.$_")) {
1883         warn << "EOM";
1884 Files "$ext$modpname/fallback.$_" and "$ext$modpname/$constsfname.$_" 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/$constsfname.c and $ext$modpname/$constsfname.xs
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 "$constsfname.c", "$constsfname.xs";
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/*>);
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 if (!$opt_c) {
2109   @files = grep {$_ ne "$constsfname.c" and $_ ne "$constsfname.xs"} @files;
2110 }
2111 print MANI join("\n",@files), "\n";
2112 close MANI;
2113 !NO!SUBS!
2114
2115 close OUT or die "Can't close $file: $!";
2116 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
2117 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
2118 chdir $origdir;