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