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