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