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