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