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 $user;
1056        ($user,$author) = (getpwuid($>))[0,6];
1057        $author =~ s/,.*$//; # in case of sub fields
1058        my $domain = $Config{'mydomain'};
1059        $domain =~ s/^\.//;
1060        $email = "$user\@$domain";
1061      };
1062
1063 $author ||= "A. U. Thor";
1064 $email  ||= 'a.u.thor@a.galaxy.far.far.away';
1065
1066 my $revhist = '';
1067 $revhist = <<EOT if $opt_C;
1068 #
1069 #=head1 HISTORY
1070 #
1071 #=over 8
1072 #
1073 #=item $TEMPLATE_VERSION
1074 #
1075 #Original version; created by h2xs $H2XS_VERSION with options
1076 #
1077 #  @ARGS
1078 #
1079 #=back
1080 #
1081 EOT
1082
1083 my $exp_doc = <<EOD;
1084 #
1085 #=head2 EXPORT
1086 #
1087 #None by default.
1088 #
1089 EOD
1090
1091 if (@const_names and not $opt_P) {
1092   $exp_doc .= <<EOD;
1093 #=head2 Exportable constants
1094 #
1095 #  @{[join "\n  ", @const_names]}
1096 #
1097 EOD
1098 }
1099
1100 if (defined $fdecls and @$fdecls and not $opt_P) {
1101   $exp_doc .= <<EOD;
1102 #=head2 Exportable functions
1103 #
1104 EOD
1105
1106 #  $exp_doc .= <<EOD if $opt_p;
1107 #When accessing these functions from Perl, prefix C<$opt_p> should be removed.
1108 #
1109 #EOD
1110   $exp_doc .= <<EOD;
1111 #  @{[join "\n  ", @known_fnames{@fnames}]}
1112 #
1113 EOD
1114 }
1115
1116 my $meth_doc = '';
1117
1118 if ($opt_x && $opt_a) {
1119   my($name, $struct);
1120   $meth_doc .= accessor_docs($name, $struct)
1121     while ($name, $struct) = each %structs;
1122 }
1123
1124 my $pod = <<"END" unless $opt_P;
1125 ## Below is stub documentation for your module. You'd better edit it!
1126 #
1127 #=head1 NAME
1128 #
1129 #$module - Perl extension for blah blah blah
1130 #
1131 #=head1 SYNOPSIS
1132 #
1133 #  use $module;
1134 #  blah blah blah
1135 #
1136 #=head1 ABSTRACT
1137 #
1138 #  This should be the abstract for $module.
1139 #  The abstract is used when making PPD (Perl Package Description) files.
1140 #  If you don't want an ABSTRACT you should also edit Makefile.PL to
1141 #  remove the ABSTRACT_FROM option.
1142 #
1143 #=head1 DESCRIPTION
1144 #
1145 #Stub documentation for $module, created by h2xs. It looks like the
1146 #author of the extension was negligent enough to leave the stub
1147 #unedited.
1148 #
1149 #Blah blah blah.
1150 $exp_doc$meth_doc$revhist
1151 #
1152 #=head1 SEE ALSO
1153 #
1154 #Mention other useful documentation such as the documentation of
1155 #related modules or operating system documentation (such as man pages
1156 #in UNIX), or any relevant external documentation such as RFCs or
1157 #standards.
1158 #
1159 #If you have a mailing list set up for your module, mention it here.
1160 #
1161 #If you have a web site set up for your module, mention it here.
1162 #
1163 #=head1 AUTHOR
1164 #
1165 #$author, E<lt>${email}E<gt>
1166 #
1167 #=head1 COPYRIGHT AND LICENSE
1168 #
1169 #Copyright ${\(1900 + (localtime) [5])} by $author
1170 #
1171 #This library is free software; you can redistribute it and/or modify
1172 #it under the same terms as Perl itself.
1173 #
1174 #=cut
1175 END
1176
1177 $pod =~ s/^\#//gm unless $opt_P;
1178 print PM $pod unless $opt_P;
1179
1180 close PM;
1181
1182
1183 if( ! $opt_X ){ # print XS, unless it is disabled
1184 warn "Writing $ext$modpname/$modfname.xs\n";
1185
1186 print XS <<"END";
1187 #include "EXTERN.h"
1188 #include "perl.h"
1189 #include "XSUB.h"
1190
1191 END
1192 if( @path_h ){
1193     foreach my $path_h (@path_h_ini) {
1194         my($h) = $path_h;
1195         $h =~ s#^/usr/include/##;
1196         if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
1197         print XS qq{#include <$h>\n};
1198     }
1199     print XS "\n";
1200 }
1201
1202 my %pointer_typedefs;
1203 my %struct_typedefs;
1204
1205 sub td_is_pointer {
1206   my $type = shift;
1207   my $out = $pointer_typedefs{$type};
1208   return $out if defined $out;
1209   my $otype = $type;
1210   $out = ($type =~ /\*$/);
1211   # This converts only the guys which do not have trailing part in the typedef
1212   if (not $out
1213       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1214     $type = normalize_type($type);
1215     print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1216       if $opt_d;
1217     $out = td_is_pointer($type);
1218   }
1219   return ($pointer_typedefs{$otype} = $out);
1220 }
1221
1222 sub td_is_struct {
1223   my $type = shift;
1224   my $out = $struct_typedefs{$type};
1225   return $out if defined $out;
1226   my $otype = $type;
1227   $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
1228   # This converts only the guys which do not have trailing part in the typedef
1229   if (not $out
1230       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1231     $type = normalize_type($type);
1232     print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
1233       if $opt_d;
1234     $out = td_is_struct($type);
1235   }
1236   return ($struct_typedefs{$otype} = $out);
1237 }
1238
1239 print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1240
1241 if( ! $opt_c ) {
1242   # We write the "sample" files used when this module is built by perl without
1243   # ExtUtils::Constant.
1244   # h2xs will later check that these are the same as those generated by the
1245   # code embedded into Makefile.PL
1246   warn "Writing $ext$modpname/fallback.c\n";
1247   warn "Writing $ext$modpname/fallback.xs\n";
1248   WriteConstants ( C_FILE =>       "fallback.c",
1249                    XS_FILE =>      "fallback.xs",
1250                    DEFAULT_TYPE => $opt_t,
1251                    NAME =>         $module,
1252                    NAMES =>        \@const_names,
1253                  );
1254   print XS "#include \"$constsfname.c\"\n";
1255 }
1256
1257
1258 my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
1259
1260 # Now switch from C to XS by issuing the first MODULE declaration:
1261 print XS <<"END";
1262
1263 MODULE = $module                PACKAGE = $module               $prefix
1264
1265 END
1266
1267 # If a constant() function was #included then output a corresponding
1268 # XS declaration:
1269 print XS "INCLUDE: $constsfname.xs\n" unless $opt_c;
1270
1271 foreach (sort keys %const_xsub) {
1272     print XS <<"END";
1273 char *
1274 $_()
1275
1276     CODE:
1277 #ifdef $_
1278         RETVAL = $_;
1279 #else
1280         croak("Your vendor has not defined the $module macro $_");
1281 #endif
1282
1283     OUTPUT:
1284         RETVAL
1285
1286 END
1287 }
1288
1289 my %seen_decl;
1290 my %typemap;
1291
1292 sub print_decl {
1293   my $fh = shift;
1294   my $decl = shift;
1295   my ($type, $name, $args) = @$decl;
1296   return if $seen_decl{$name}++; # Need to do the same for docs as well?
1297
1298   my @argnames = map {$_->[1]} @$args;
1299   my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
1300   if ($opt_k) {
1301     s/^\s*const\b\s*// for @argtypes;
1302   }
1303   my @argarrays = map { $_->[4] || '' } @$args;
1304   my $numargs = @$args;
1305   if ($numargs and $argtypes[-1] eq '...') {
1306     $numargs--;
1307     $argnames[-1] = '...';
1308   }
1309   local $" = ', ';
1310   $type = normalize_type($type, 1);
1311
1312   print $fh <<"EOP";
1313
1314 $type
1315 $name(@argnames)
1316 EOP
1317
1318   for my $arg (0 .. $numargs - 1) {
1319     print $fh <<"EOP";
1320         $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
1321 EOP
1322   }
1323 }
1324
1325 sub print_tievar_subs {
1326   my($fh, $name, $type) = @_;
1327   print $fh <<END;
1328 I32
1329 _get_$name(IV index, SV *sv) {
1330     dSP;
1331     PUSHMARK(SP);
1332     XPUSHs(sv);
1333     PUTBACK;
1334     (void)call_pv("$module\::_get_$name", G_DISCARD);
1335     return (I32)0;
1336 }
1337
1338 I32
1339 _set_$name(IV index, SV *sv) {
1340     dSP;
1341     PUSHMARK(SP);
1342     XPUSHs(sv);
1343     PUTBACK;
1344     (void)call_pv("$module\::_set_$name", G_DISCARD);
1345     return (I32)0;
1346 }
1347
1348 END
1349 }
1350
1351 sub print_tievar_xsubs {
1352   my($fh, $name, $type) = @_;
1353   print $fh <<END;
1354 void
1355 _tievar_$name(sv)
1356         SV* sv
1357     PREINIT:
1358         struct ufuncs uf;
1359     CODE:
1360         uf.uf_val = &_get_$name;
1361         uf.uf_set = &_set_$name;
1362         uf.uf_index = (IV)&_get_$name;
1363         sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1364
1365 void
1366 _get_$name(THIS)
1367         $type THIS = NO_INIT
1368     CODE:
1369         THIS = $name;
1370     OUTPUT:
1371         SETMAGIC: DISABLE
1372         THIS
1373
1374 void
1375 _set_$name(THIS)
1376         $type THIS
1377     CODE:
1378         $name = THIS;
1379
1380 END
1381 }
1382
1383 sub print_accessors {
1384   my($fh, $name, $struct) = @_;
1385   return unless defined $struct && $name !~ /\s|_ANON/;
1386   $name = normalize_type($name);
1387   my $ptrname = normalize_type("$name *");
1388   print $fh <<"EOF";
1389
1390 MODULE = $module                PACKAGE = ${name}               $prefix
1391
1392 $name *
1393 _to_ptr(THIS)
1394         $name THIS = NO_INIT
1395     PROTOTYPE: \$
1396     CODE:
1397         if (sv_derived_from(ST(0), "$name")) {
1398             STRLEN len;
1399             char *s = SvPV((SV*)SvRV(ST(0)), len);
1400             if (len != sizeof(THIS))
1401                 croak("Size \%d of packed data != expected \%d",
1402                         len, sizeof(THIS));
1403             RETVAL = ($name *)s;
1404         }
1405         else
1406             croak("THIS is not of type $name");
1407     OUTPUT:
1408         RETVAL
1409
1410 $name
1411 new(CLASS)
1412         char *CLASS = NO_INIT
1413     PROTOTYPE: \$
1414     CODE:
1415         Zero((void*)&RETVAL, sizeof(RETVAL), char);
1416     OUTPUT:
1417         RETVAL
1418
1419 MODULE = $module                PACKAGE = ${name}Ptr            $prefix
1420
1421 EOF
1422   my @items = @$struct;
1423   while (@items) {
1424     my $item = shift @items;
1425     if ($item->[0] =~ /_ANON/) {
1426       if (defined $item->[2]) {
1427         push @items, map [
1428           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1429         ], @{ $structs{$item->[0]} };
1430       } else {
1431         push @items, @{ $structs{$item->[0]} };
1432       }
1433     } else {
1434       my $type = normalize_type($item->[0]);
1435       my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
1436       print $fh <<"EOF";
1437 $ttype
1438 $item->[2](THIS, __value = NO_INIT)
1439         $ptrname THIS
1440         $type __value
1441     PROTOTYPE: \$;\$
1442     CODE:
1443         if (items > 1)
1444             THIS->$item->[-1] = __value;
1445         RETVAL = @{[
1446             $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1447         ]};
1448     OUTPUT:
1449         RETVAL
1450
1451 EOF
1452     }
1453   }
1454 }
1455
1456 sub accessor_docs {
1457   my($name, $struct) = @_;
1458   return unless defined $struct && $name !~ /\s|_ANON/;
1459   $name = normalize_type($name);
1460   my $ptrname = $name . 'Ptr';
1461   my @items = @$struct;
1462   my @list;
1463   while (@items) {
1464     my $item = shift @items;
1465     if ($item->[0] =~ /_ANON/) {
1466       if (defined $item->[2]) {
1467         push @items, map [
1468           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1469         ], @{ $structs{$item->[0]} };
1470       } else {
1471         push @items, @{ $structs{$item->[0]} };
1472       }
1473     } else {
1474       push @list, $item->[2];
1475     }
1476   }
1477   my $methods = (join '(...)>, C<', @list) . '(...)';
1478
1479   my $pod = <<"EOF";
1480 #
1481 #=head2 Object and class methods for C<$name>/C<$ptrname>
1482 #
1483 #The principal Perl representation of a C object of type C<$name> is an
1484 #object of class C<$ptrname> which is a reference to an integer
1485 #representation of a C pointer.  To create such an object, one may use
1486 #a combination
1487 #
1488 #  my \$buffer = $name->new();
1489 #  my \$obj = \$buffer->_to_ptr();
1490 #
1491 #This exersizes the following two methods, and an additional class
1492 #C<$name>, the internal representation of which is a reference to a
1493 #packed string with the C structure.  Keep in mind that \$buffer should
1494 #better survive longer than \$obj.
1495 #
1496 #=over
1497 #
1498 #=item C<\$object_of_type_$name-E<gt>_to_ptr()>
1499 #
1500 #Converts an object of type C<$name> to an object of type C<$ptrname>.
1501 #
1502 #=item C<$name-E<gt>new()>
1503 #
1504 #Creates an empty object of type C<$name>.  The corresponding packed
1505 #string is zeroed out.
1506 #
1507 #=item C<$methods>
1508 #
1509 #return the current value of the corresponding element if called
1510 #without additional arguments.  Set the element to the supplied value
1511 #(and return the new value) if called with an additional argument.
1512 #
1513 #Applicable to objects of type C<$ptrname>.
1514 #
1515 #=back
1516 #
1517 EOF
1518   $pod =~ s/^\#//gm;
1519   return $pod;
1520 }
1521
1522 # Should be called before any actual call to normalize_type().
1523 sub get_typemap {
1524   # We do not want to read ./typemap by obvios reasons.
1525   my @tm =  qw(../../../typemap ../../typemap ../typemap);
1526   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
1527   unshift @tm, $stdtypemap;
1528   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
1529
1530   # Start with useful default values
1531   $typemap{float} = 'T_NV';
1532
1533   foreach my $typemap (@tm) {
1534     next unless -e $typemap ;
1535     # skip directories, binary files etc.
1536     warn " Scanning $typemap\n";
1537     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1538       unless -T $typemap ;
1539     open(TYPEMAP, $typemap)
1540       or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1541     my $mode = 'Typemap';
1542     while (<TYPEMAP>) {
1543       next if /^\s*\#/;
1544       if (/^INPUT\s*$/)   { $mode = 'Input'; next; }
1545       elsif (/^OUTPUT\s*$/)  { $mode = 'Output'; next; }
1546       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1547       elsif ($mode eq 'Typemap') {
1548         next if /^\s*($|\#)/ ;
1549         my ($type, $image);
1550         if ( ($type, $image) =
1551              /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1552              # This may reference undefined functions:
1553              and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
1554           $typemap{normalize_type($type)} = $image;
1555         }
1556       }
1557     }
1558     close(TYPEMAP) or die "Cannot close $typemap: $!";
1559   }
1560   %std_types = %types_seen;
1561   %types_seen = ();
1562 }
1563
1564
1565 sub normalize_type {            # Second arg: do not strip const's before \*
1566   my $type = shift;
1567   my $do_keep_deep_const = shift;
1568   # If $do_keep_deep_const this is heuristical only
1569   my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
1570   my $ignore_mods
1571     = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1572   if ($do_keep_deep_const) {    # Keep different compiled /RExen/o separately!
1573     $type =~ s/$ignore_mods//go;
1574   }
1575   else {
1576     $type =~ s/$ignore_mods//go;
1577   }
1578   $type =~ s/([^\s\w])/ $1 /g;
1579   $type =~ s/\s+$//;
1580   $type =~ s/^\s+//;
1581   $type =~ s/\s+/ /g;
1582   $type =~ s/\* (?=\*)/*/g;
1583   $type =~ s/\. \. \./.../g;
1584   $type =~ s/ ,/,/g;
1585   $types_seen{$type}++
1586     unless $type eq '...' or $type eq 'void' or $std_types{$type};
1587   $type;
1588 }
1589
1590 my $need_opaque;
1591
1592 sub assign_typemap_entry {
1593   my $type = shift;
1594   my $otype = $type;
1595   my $entry;
1596   if ($tmask and $type =~ /$tmask/) {
1597     print "Type $type matches -o mask\n" if $opt_d;
1598     $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1599   }
1600   elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1601     $type = normalize_type $type;
1602     print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1603     $entry = assign_typemap_entry($type);
1604   }
1605   # XXX good do better if our UV happens to be long long
1606   return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/;
1607   $entry ||= $typemap{$otype}
1608     || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1609   $typemap{$otype} = $entry;
1610   $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1611   return $entry;
1612 }
1613
1614 for (@vdecls) {
1615   print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
1616 }
1617
1618 if ($opt_x) {
1619   for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1620   if ($opt_a) {
1621     while (my($name, $struct) = each %structs) {
1622       print_accessors(\*XS, $name, $struct);
1623     }
1624   }
1625 }
1626
1627 close XS;
1628
1629 if (%types_seen) {
1630   my $type;
1631   warn "Writing $ext$modpname/typemap\n";
1632   open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1633
1634   for $type (sort keys %types_seen) {
1635     my $entry = assign_typemap_entry $type;
1636     print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
1637   }
1638
1639   print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1640 #############################################################################
1641 INPUT
1642 T_OPAQUE_STRUCT
1643         if (sv_derived_from($arg, \"${ntype}\")) {
1644             STRLEN len;
1645             char  *s = SvPV((SV*)SvRV($arg), len);
1646
1647             if (len != sizeof($var))
1648                 croak(\"Size %d of packed data != expected %d\",
1649                         len, sizeof($var));
1650             $var = *($type *)s;
1651         }
1652         else
1653             croak(\"$var is not of type ${ntype}\")
1654 #############################################################################
1655 OUTPUT
1656 T_OPAQUE_STRUCT
1657         sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1658 EOP
1659
1660   close TM or die "Cannot close typemap file for write: $!";
1661 }
1662
1663 } # if( ! $opt_X )
1664
1665 warn "Writing $ext$modpname/Makefile.PL\n";
1666 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
1667
1668 my $prereq_pm;
1669
1670 if ( $compat_version < 5.00702 and $new_test )
1671 {
1672   $prereq_pm = q%'Test::More'  =>  0%;
1673 }
1674 else
1675 {
1676   $prereq_pm = '';
1677 }
1678
1679 print PL <<"END";
1680 use $compat_version;
1681 use ExtUtils::MakeMaker;
1682 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
1683 # the contents of the Makefile that is written.
1684 WriteMakefile(
1685     'NAME'              => '$module',
1686     'VERSION_FROM'      => '$modfname.pm', # finds \$VERSION
1687     'PREREQ_PM'         => {$prereq_pm}, # e.g., Module::Name => 1.1
1688     (\$] >= 5.005 ?    ## Add these new keywords supported since 5.005
1689       (ABSTRACT_FROM => '$modfname.pm', # retrieve abstract from module
1690        AUTHOR     => '$author <$email>') : ()),
1691 END
1692 if (!$opt_X) { # print C stuff, unless XS is disabled
1693   $opt_F = '' unless defined $opt_F;
1694   my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
1695   my $Ihelp = ($I ? '-I. ' : '');
1696   my $Icomment = ($I ? '' : <<EOC);
1697         # Insert -I. if you add *.h files later:
1698 EOC
1699
1700   print PL <<END;
1701     'LIBS'              => ['$extralibs'], # e.g., '-lm'
1702     'DEFINE'            => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1703 $Icomment    'INC'              => '$I', # e.g., '${Ihelp}-I/usr/include/other'
1704 END
1705
1706   if (!$opt_c) {
1707     print PL <<"END";
1708     # Without this the constants xs files are spotted, and cause rules to be
1709     # added to delete the similarly names C files, which isn't what we want.
1710     'XS'                => {'$modfname.xs' => '$modfname.c'},
1711     realclean           => {FILES => '$constsfname.c $constsfname.xs'},
1712 END
1713   }
1714
1715   my $C = grep {$_ ne "$modfname.c" && $_ ne "fallback.c"}
1716     (glob '*.c'), (glob '*.cc'), (glob '*.C');
1717   my $Cpre = ($C ? '' : '# ');
1718   my $Ccomment = ($C ? '' : <<EOC);
1719         # Un-comment this if you add C files to link with later:
1720 EOC
1721
1722   print PL <<END;
1723 $Ccomment    $Cpre\'OBJECT'             => '\$(O_FILES)', # link all the C files too
1724 END
1725 } # ' # Grr
1726 print PL ");\n";
1727 if (!$opt_c) {
1728   my $generate_code =
1729     WriteMakefileSnippet ( C_FILE =>       "$constsfname.c",
1730                            XS_FILE =>      "$constsfname.xs",
1731                            DEFAULT_TYPE => $opt_t,
1732                            NAME =>         $module,
1733                            NAMES =>        \@const_names,
1734                  );
1735   print PL <<"END";
1736 if  (eval {require ExtUtils::Constant; 1}) {
1737   # If you edit these definitions to change the constants used by this module,
1738   # you will need to use the generated $constsfname.c and $constsfname.xs
1739   # files to replace their "fallback" counterparts before distributing your
1740   # changes.
1741 $generate_code
1742 }
1743 else {
1744   use File::Copy;
1745   copy ('fallback.c', '$constsfname.c')
1746     or die "Can't copy fallback.c to $constsfname.c: \$!";
1747   copy ('fallback.xs', '$constsfname.xs')
1748     or die "Can't copy fallback.xs to $constsfname.xs: \$!";
1749 }
1750 END
1751
1752   eval $generate_code;
1753   if ($@) {
1754     warn <<"EOM";
1755 Attempting to test constant code in $ext$modpname/Makefile.PL:
1756 $generate_code
1757 __END__
1758 gave unexpected error $@
1759 Please report the circumstances of this bug in h2xs version $H2XS_VERSION
1760 using the perlbug script.
1761 EOM
1762   } else {
1763     my $fail;
1764
1765     foreach ('c', 'xs') {
1766       if (compare("fallback.$_", "$constsfname.$_")) {
1767         warn << "EOM";
1768 Files "$ext$modpname/fallback.$_" and "$ext$modpname/$constsfname.$_" differ.
1769 EOM
1770         $fail++;
1771       }
1772     }
1773     if ($fail) {
1774       warn fill ('','', <<"EOM") . "\n";
1775 It appears that the code in $ext$modpname/Makefile.PL does not autogenerate
1776 the files $ext$modpname/$constsfname.c and $ext$modpname/$constsfname.xs
1777 correctly.
1778
1779 Please report the circumstances of this bug in h2xs version $H2XS_VERSION
1780 using the perlbug script.
1781 EOM
1782     } else {
1783       unlink "$constsfname.c", "$constsfname.xs";
1784     }
1785   }
1786 }
1787 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
1788
1789 # Create a simple README since this is a CPAN requirement
1790 # and it doesnt hurt to have one
1791 warn "Writing $ext$modpname/README\n";
1792 open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
1793 my $thisyear = (gmtime)[5] + 1900;
1794 my $rmhead = "$modpname version $TEMPLATE_VERSION";
1795 my $rmheadeq = "=" x length($rmhead);
1796
1797 my $rm_prereq;
1798
1799 if ( $compat_version < 5.00702 and $new_test )
1800 {
1801    $rm_prereq = 'Test::More';
1802 }
1803 else
1804 {
1805    $rm_prereq = 'blah blah blah';
1806 }
1807
1808 print RM <<_RMEND_;
1809 $rmhead
1810 $rmheadeq
1811
1812 The README is used to introduce the module and provide instructions on
1813 how to install the module, any machine dependencies it may have (for
1814 example C compilers and installed libraries) and any other information
1815 that should be provided before the module is installed.
1816
1817 A README file is required for CPAN modules since CPAN extracts the
1818 README file from a module distribution so that people browsing the
1819 archive can use it get an idea of the modules uses. It is usually a
1820 good idea to provide version information here so that people can
1821 decide whether fixes for the module are worth downloading.
1822
1823 INSTALLATION
1824
1825 To install this module type the following:
1826
1827    perl Makefile.PL
1828    make
1829    make test
1830    make install
1831
1832 DEPENDENCIES
1833
1834 This module requires these other modules and libraries:
1835
1836   $rm_prereq
1837
1838 COPYRIGHT AND LICENCE
1839
1840 Put the correct copyright and licence information here.
1841
1842 Copyright (C) $thisyear $author
1843
1844 This library is free software; you can redistribute it and/or modify
1845 it under the same terms as Perl itself.
1846
1847 _RMEND_
1848 close(RM) || die "Can't close $ext$modpname/README: $!\n";
1849
1850 my $testdir  = "t";
1851 my $testfile = "$testdir/1.t";
1852 unless (-d "$testdir") {
1853   mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n";
1854 }
1855 warn "Writing $ext$modpname/$testfile\n";
1856 my $tests = @const_names ? 2 : 1;
1857
1858 open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n";
1859
1860 print EX <<_END_;
1861 # Before `make install' is performed this script should be runnable with
1862 # `make test'. After `make install' it should work as `perl 1.t'
1863
1864 #########################
1865
1866 # change 'tests => $tests' to 'tests => last_test_to_print';
1867
1868 _END_
1869
1870 my $test_mod = 'Test::More';
1871
1872 if ( $old_test or ($compat_version < 5.007 and not $new_test ))
1873 {
1874   my $test_mod = 'Test';
1875
1876   print EX <<_END_;
1877 use Test;
1878 BEGIN { plan tests => $tests };
1879 use $module;
1880 ok(1); # If we made it this far, we're ok.
1881
1882 _END_
1883
1884    if (@const_names) {
1885      my $const_names = join " ", @const_names;
1886      print EX <<'_END_';
1887
1888 my $fail;
1889 foreach my $constname (qw(
1890 _END_
1891
1892      print EX wrap ("\t", "\t", $const_names);
1893      print EX (")) {\n");
1894
1895      print EX <<_END_;
1896   next if (eval "my \\\$a = \$constname; 1");
1897   if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
1898     print "# pass: \$\@";
1899   } else {
1900     print "# fail: \$\@";
1901     \$fail = 1;
1902   }
1903 }
1904 if (\$fail) {
1905   print "not ok 2\\n";
1906 } else {
1907   print "ok 2\\n";
1908 }
1909
1910 _END_
1911   }
1912 }
1913 else
1914 {
1915   print EX <<_END_;
1916 use Test::More tests => $tests;
1917 BEGIN { use_ok('$module') };
1918
1919 _END_
1920
1921    if (@const_names) {
1922      my $const_names = join " ", @const_names;
1923      print EX <<'_END_';
1924
1925 my $fail = 0;
1926 foreach my $constname (qw(
1927 _END_
1928
1929      print EX wrap ("\t", "\t", $const_names);
1930      print EX (")) {\n");
1931
1932      print EX <<_END_;
1933   next if (eval "my \\\$a = \$constname; 1");
1934   if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
1935     print "# pass: \$\@";
1936   } else {
1937     print "# fail: \$\@";
1938     \$fail = 1;
1939   }
1940
1941 }
1942
1943 ok( \$fail == 0 , 'Constants' );
1944 _END_
1945   }
1946 }
1947
1948 print EX <<_END_;
1949 #########################
1950
1951 # Insert your test code below, the $test_mod module is use()ed here so read
1952 # its man page ( perldoc $test_mod ) for help writing this test script.
1953
1954 _END_
1955
1956 close(EX) || die "Can't close $ext$modpname/$testfile: $!\n";
1957
1958 unless ($opt_C) {
1959   warn "Writing $ext$modpname/Changes\n";
1960   $" = ' ';
1961   open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
1962   @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
1963   print EX <<EOP;
1964 Revision history for Perl extension $module.
1965
1966 $TEMPLATE_VERSION  @{[scalar localtime]}
1967 \t- original version; created by h2xs $H2XS_VERSION with options
1968 \t\t@ARGS
1969
1970 EOP
1971   close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
1972 }
1973
1974 warn "Writing $ext$modpname/MANIFEST\n";
1975 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
1976 my @files = grep { -f } (<*>, <t/*>);
1977 if (!@files) {
1978   eval {opendir(D,'.');};
1979   unless ($@) { @files = readdir(D); closedir(D); }
1980 }
1981 if (!@files) { @files = map {chomp && $_} `ls`; }
1982 if ($^O eq 'VMS') {
1983   foreach (@files) {
1984     # Clip trailing '.' for portability -- non-VMS OSs don't expect it
1985     s%\.$%%;
1986     # Fix up for case-sensitive file systems
1987     s/$modfname/$modfname/i && next;
1988     $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
1989     $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
1990   }
1991 }
1992 if (!$opt_c) {
1993   @files = grep {$_ ne "$constsfname.c" and $_ ne "$constsfname.xs"} @files;
1994 }
1995 print MANI join("\n",@files), "\n";
1996 close MANI;
1997 !NO!SUBS!
1998
1999 close OUT or die "Can't close $file: $!";
2000 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
2001 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
2002 chdir $origdir;