utils/h2xs.PL

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