This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
If perl's minimal required version number is >= 5.6.0,
[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 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.7.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 compatibile 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             # Cannot do: (-1) and ((LHANDLE)3) are OK:
866             #print("Skip non-wordy $def => $rest\n"),
867             #  next defines if $rest =~ /[^\w\$]/;
868             if ($rest =~ /"/) {
869               print("Skip stringy $def => $rest\n") if $opt_d;
870               next defines;
871             }
872             print "Matched $_ ($def)\n" if $opt_d;
873             $seen_define{$def} = $rest;
874             $_ = $def;
875             next if /^_.*_h_*$/i; # special case, but for what?
876             if (defined $opt_p) {
877               if (!/^$opt_p(\d)/) {
878                 ++$prefix{$_} if s/^$opt_p//;
879               }
880               else {
881                 warn "can't remove $opt_p prefix from '$_'!\n";
882               }
883             }
884             $prefixless{$def} = $_;
885             if (!$fmask or /$fmask/) {
886                 print "... Passes mask of -M.\n" if $opt_d and $fmask;
887                 $const_names{$_}++;
888             }
889           }
890       }
891       if (defined $opt_e and !$opt_e) {
892         close(CH);
893       }
894       else {
895         # Work from miniperl too - on "normal" systems
896         my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' or 0;
897         seek CH, 0, $SEEK_SET;
898         my $src = do { local $/; <CH> };
899         close CH;
900         no warnings 'uninitialized';
901
902         # Remove C and C++ comments
903         $src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs;
904
905         while ($src =~ /\benum\s*([\w_]*)\s*\{\s([^}]+)\}/gsc) {
906             my ($enum_name, $enum_body) = ($1, $2);
907             # skip enums matching $opt_e
908             next if $opt_e && $enum_name =~ /$opt_e/;
909             my $val = 0;
910             for my $item (split /,/, $enum_body) {
911                 next if $item =~ /\A\s*\Z/;
912                 my ($key, $declared_val) = $item =~ /(\w+)\s*(?:=\s*(.*))?/;
913                 $val = defined($declared_val) && length($declared_val) ? $declared_val : 1 + $val;
914                 $seen_define{$key} = $val;
915                 $const_names{$key}++;
916             }
917         } # while (...)
918       } # if (!defined $opt_e or $opt_e)
919     }
920     }
921 }
922
923 # Save current directory so that C::Scan can use it
924 my $cwd = File::Spec->rel2abs( File::Spec->curdir );
925
926 # As Ilya suggested, use a name that contains - and then it can't clash with
927 # the names of any packages. A directory 'fallback' will clash with any
928 # new pragmata down the fallback:: tree, but that seems unlikely.
929 my $constscfname = 'const-c.inc';
930 my $constsxsfname = 'const-xs.inc';
931 my $fallbackdirname = 'fallback';
932
933 my $ext = chdir 'ext' ? 'ext/' : '';
934
935 my @modparts  = split(/::/,$module);
936 my $modpname  = join('-', @modparts);
937 my $modfname  = pop @modparts;
938 my $modpmdir  = join '/', 'lib', @modparts;
939 my $modpmname = join '/', $modpmdir, $modfname.'.pm';
940
941 if ($opt_O) {
942         warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
943 }
944 else {
945         die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
946 }
947 -d "$modpname"   || mkpath([$modpname], 0, 0775);
948 chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
949
950 my %types_seen;
951 my %std_types;
952 my $fdecls = [];
953 my $fdecls_parsed = [];
954 my $typedef_rex;
955 my %typedefs_pre;
956 my %known_fnames;
957 my %structs;
958
959 my @fnames;
960 my @fnames_no_prefix;
961 my %vdecl_hash;
962 my @vdecls;
963
964 if( ! $opt_X ){  # use XS, unless it was disabled
965   unless ($skip_ppport) {
966     require Devel::PPPort;
967     warn "Writing $ext$modpname/ppport.h\n";
968     Devel::PPPort::WriteFile('ppport.h')
969         || die "Can't create $ext$modpname/ppport.h: $!\n";
970   }
971   open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
972   if ($opt_x) {
973     warn "Scanning typemaps...\n";
974     get_typemap();
975     my @td;
976     my @good_td;
977     my $addflags = $opt_F || '';
978
979     foreach my $filename (@path_h) {
980       my $c;
981       my $filter;
982
983       if ($fullpath{$filename} =~ /,/) {
984         $filename = $`;
985         $filter = $';
986       }
987       warn "Scanning $filename for functions...\n";
988       my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X);
989       $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
990         'add_cppflags' => $addflags, 'c_styles' => \@styles;
991       $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]);
992
993       $c->get('keywords')->{'__restrict'} = 1;
994
995       push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
996       push(@$fdecls, @{$c->get('fdecls')});
997
998       push @td, @{$c->get('typedefs_maybe')};
999       if ($opt_a) {
1000         my $structs = $c->get('typedef_structs');
1001         @structs{keys %$structs} = values %$structs;
1002       }
1003
1004       if ($opt_m) {
1005         %vdecl_hash = %{ $c->get('vdecl_hash') };
1006         @vdecls = sort keys %vdecl_hash;
1007         for (local $_ = 0; $_ < @vdecls; ++$_) {
1008           my $var = $vdecls[$_];
1009           my($type, $post) = @{ $vdecl_hash{$var} };
1010           if (defined $post) {
1011             warn "Can't handle variable '$type $var $post', skipping.\n";
1012             splice @vdecls, $_, 1;
1013             redo;
1014           }
1015           $type = normalize_type($type);
1016           $vdecl_hash{$var} = $type;
1017         }
1018       }
1019
1020       unless ($tmask_all) {
1021         warn "Scanning $filename for typedefs...\n";
1022         my $td = $c->get('typedef_hash');
1023         # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
1024         my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
1025         push @good_td, @f_good_td;
1026         @typedefs_pre{@f_good_td}  = map $_->[0], @$td{@f_good_td};
1027       }
1028     }
1029     { local $" = '|';
1030       $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
1031     }
1032     %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
1033     if ($fmask) {
1034       my @good;
1035       for my $i (0..$#$fdecls_parsed) {
1036         next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
1037         push @good, $i;
1038         print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
1039           if $opt_d;
1040       }
1041       $fdecls = [@$fdecls[@good]];
1042       $fdecls_parsed = [@$fdecls_parsed[@good]];
1043     }
1044     @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
1045     # Sort declarations:
1046     {
1047       my %h = map( ($_->[1], $_), @$fdecls_parsed);
1048       $fdecls_parsed = [ @h{@fnames} ];
1049     }
1050     @fnames_no_prefix = @fnames;
1051     @fnames_no_prefix
1052       = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix
1053          if defined $opt_p;
1054     # Remove macros which expand to typedefs
1055     print "Typedefs are @td.\n" if $opt_d;
1056     my %td = map {($_, $_)} @td;
1057     # Add some other possible but meaningless values for macros
1058     for my $k (qw(char double float int long short unsigned signed void)) {
1059       $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
1060     }
1061     # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
1062     my $n = 0;
1063     my %bad_macs;
1064     while (keys %td > $n) {
1065       $n = keys %td;
1066       my ($k, $v);
1067       while (($k, $v) = each %seen_define) {
1068         # print("found '$k'=>'$v'\n"),
1069         $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
1070       }
1071     }
1072     # Now %bad_macs contains names of bad macros
1073     for my $k (keys %bad_macs) {
1074       delete $const_names{$prefixless{$k}};
1075       print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
1076     }
1077   }
1078 }
1079 my @const_names = sort keys %const_names;
1080
1081 -d $modpmdir || mkpath([$modpmdir], 0, 0775);
1082 open(PM, ">$modpmname") || die "Can't create $ext$modpname/$modpmname: $!\n";
1083
1084 $" = "\n\t";
1085 warn "Writing $ext$modpname/$modpmname\n";
1086
1087 print PM <<"END";
1088 package $module;
1089
1090 use $compat_version;
1091 END
1092
1093 print PM <<"END" unless $skip_strict;
1094 use strict;
1095 END
1096
1097 print PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006;
1098
1099 unless( $opt_X || $opt_c || $opt_A ){
1100         # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
1101         # will want Carp.
1102         print PM <<'END';
1103 use Carp;
1104 END
1105 }
1106
1107 print PM <<'END' unless $skip_exporter;
1108
1109 require Exporter;
1110 END
1111
1112 my $use_Dyna = (not $opt_X and $compat_version < 5.006 and not $use_xsloader);
1113 print PM <<"END" if $use_Dyna;  # use DynaLoader, unless XS was disabled
1114 require DynaLoader;
1115 END
1116
1117
1118 # Are we using AutoLoader or not?
1119 unless ($skip_autoloader) { # no autoloader whatsoever.
1120         unless ($opt_c) { # we're doing the AUTOLOAD
1121                 print PM "use AutoLoader;\n";
1122         }
1123         else {
1124                 print PM "use AutoLoader qw(AUTOLOAD);\n"
1125         }
1126 }
1127
1128 if ( $compat_version < 5.006 ) {
1129     my $vars = '$VERSION @ISA';
1130     $vars .= ' @EXPORT @EXPORT_OK %EXPORT_TAGS' unless $skip_exporter;
1131     $vars .= ' $AUTOLOAD' unless $opt_X || $opt_c || $opt_A;
1132     $vars .= ' $XS_VERSION' if $opt_B && !$opt_X;
1133     print PM "use vars qw($vars);";
1134 }
1135
1136 # Determine @ISA.
1137 my @modISA;
1138 push @modISA, 'Exporter'        unless $skip_exporter;
1139 push @modISA, 'DynaLoader'      if $use_Dyna;  # no XS
1140 my $myISA = "our \@ISA = qw(@modISA);";
1141 $myISA =~ s/^our // if $compat_version < 5.006;
1142
1143 print PM "\n$myISA\n\n";
1144
1145 my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
1146
1147 my $tmp='';
1148 $tmp .= <<"END" unless $skip_exporter;
1149 # Items to export into callers namespace by default. Note: do not export
1150 # names by default without a very good reason. Use EXPORT_OK instead.
1151 # Do not simply export all your public functions/methods/constants.
1152
1153 # This allows declaration       use $module ':all';
1154 # If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
1155 # will save memory.
1156 our %EXPORT_TAGS = ( 'all' => [ qw(
1157         @exported_names
1158 ) ] );
1159
1160 our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
1161
1162 our \@EXPORT = qw(
1163         @const_names
1164 );
1165
1166 END
1167
1168 $tmp .= "our \$VERSION = '$TEMPLATE_VERSION';\n";
1169 if ($opt_B) {
1170     $tmp .= "our \$XS_VERSION = \$VERSION;\n" unless $opt_X;
1171     $tmp .= "\$VERSION = eval \$VERSION;  # see L<perlmodstyle>\n";
1172 }
1173 $tmp .= "\n";
1174
1175 $tmp =~ s/^our //mg if $compat_version < 5.006;
1176 print PM $tmp;
1177
1178 if (@vdecls) {
1179     printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
1180 }
1181
1182
1183 print PM autoload ($module, $compat_version) unless $opt_c or $opt_X;
1184
1185 if( ! $opt_X ){ # print bootstrap, unless XS is disabled
1186   if ($use_Dyna) {
1187         $tmp = <<"END";
1188 bootstrap $module \$VERSION;
1189 END
1190   } else {
1191         $tmp = <<"END";
1192 require XSLoader;
1193 XSLoader::load('$module', \$VERSION);
1194 END
1195   }
1196   $tmp =~ s:\$VERSION:\$XS_VERSION:g if $opt_B;
1197   print PM $tmp;
1198 }
1199
1200 # tying the variables can happen only after bootstrap
1201 if (@vdecls) {
1202     printf PM <<END;
1203 {
1204 @{[ join "\n", map "    _tievar_$_(\$$_);", @vdecls ]}
1205 }
1206
1207 END
1208 }
1209
1210 my $after;
1211 if( $opt_P ){ # if POD is disabled
1212         $after = '__END__';
1213 }
1214 else {
1215         $after = '=cut';
1216 }
1217
1218 print PM <<"END";
1219
1220 # Preloaded methods go here.
1221 END
1222
1223 print PM <<"END" unless $opt_A;
1224
1225 # Autoload methods go after $after, and are processed by the autosplit program.
1226 END
1227
1228 print PM <<"END";
1229
1230 1;
1231 __END__
1232 END
1233
1234 my ($email,$author,$licence);
1235
1236 eval {
1237        my $username;
1238        ($username,$author) = (getpwuid($>))[0,6];
1239        if (defined $username && defined $author) {
1240            $author =~ s/,.*$//; # in case of sub fields
1241            my $domain = $Config{'mydomain'};
1242            $domain =~ s/^\.//;
1243            $email = "$username\@$domain";
1244        }
1245      };
1246
1247 $author =~ s/'/\\'/g if defined $author;
1248 $author ||= "A. U. Thor";
1249 $email  ||= 'a.u.thor@a.galaxy.far.far.away';
1250
1251 $licence = sprintf << "DEFAULT", $^V;
1252 Copyright (C) ${\(1900 + (localtime) [5])} by $author
1253
1254 This library is free software; you can redistribute it and/or modify
1255 it under the same terms as Perl itself, either Perl version %vd or,
1256 at your option, any later version of Perl 5 you may have available.
1257 DEFAULT
1258
1259 my $revhist = '';
1260 $revhist = <<EOT if $opt_C;
1261 #
1262 #=head1 HISTORY
1263 #
1264 #=over 8
1265 #
1266 #=item $TEMPLATE_VERSION
1267 #
1268 #Original version; created by h2xs $H2XS_VERSION with options
1269 #
1270 #  @ARGS
1271 #
1272 #=back
1273 #
1274 EOT
1275
1276 my $exp_doc = $skip_exporter ? '' : <<EOD;
1277 #
1278 #=head2 EXPORT
1279 #
1280 #None by default.
1281 #
1282 EOD
1283
1284 if (@const_names and not $opt_P) {
1285   $exp_doc .= <<EOD unless $skip_exporter;
1286 #=head2 Exportable constants
1287 #
1288 #  @{[join "\n  ", @const_names]}
1289 #
1290 EOD
1291 }
1292
1293 if (defined $fdecls and @$fdecls and not $opt_P) {
1294   $exp_doc .= <<EOD unless $skip_exporter;
1295 #=head2 Exportable functions
1296 #
1297 EOD
1298
1299 #  $exp_doc .= <<EOD if $opt_p;
1300 #When accessing these functions from Perl, prefix C<$opt_p> should be removed.
1301 #
1302 #EOD
1303   $exp_doc .= <<EOD unless $skip_exporter;
1304 #  @{[join "\n  ", @known_fnames{@fnames}]}
1305 #
1306 EOD
1307 }
1308
1309 my $meth_doc = '';
1310
1311 if ($opt_x && $opt_a) {
1312   my($name, $struct);
1313   $meth_doc .= accessor_docs($name, $struct)
1314     while ($name, $struct) = each %structs;
1315 }
1316
1317 # Prefix the default licence with hash symbols.
1318 # Is this just cargo cult - it seems that the first thing that happens to this
1319 # block is that all the hashes are then s///g out.
1320 my $licence_hash = $licence;
1321 $licence_hash =~ s/^/#/gm;
1322
1323 my $pod;
1324 $pod = <<"END" unless $opt_P;
1325 ## Below is stub documentation for your module. You'd better edit it!
1326 #
1327 #=head1 NAME
1328 #
1329 #$module - Perl extension for blah blah blah
1330 #
1331 #=head1 SYNOPSIS
1332 #
1333 #  use $module;
1334 #  blah blah blah
1335 #
1336 #=head1 DESCRIPTION
1337 #
1338 #Stub documentation for $module, created by h2xs. It looks like the
1339 #author of the extension was negligent enough to leave the stub
1340 #unedited.
1341 #
1342 #Blah blah blah.
1343 $exp_doc$meth_doc$revhist
1344 #
1345 #=head1 SEE ALSO
1346 #
1347 #Mention other useful documentation such as the documentation of
1348 #related modules or operating system documentation (such as man pages
1349 #in UNIX), or any relevant external documentation such as RFCs or
1350 #standards.
1351 #
1352 #If you have a mailing list set up for your module, mention it here.
1353 #
1354 #If you have a web site set up for your module, mention it here.
1355 #
1356 #=head1 AUTHOR
1357 #
1358 #$author, E<lt>${email}E<gt>
1359 #
1360 #=head1 COPYRIGHT AND LICENSE
1361 #
1362 $licence_hash
1363 #
1364 #=cut
1365 END
1366
1367 $pod =~ s/^\#//gm unless $opt_P;
1368 print PM $pod unless $opt_P;
1369
1370 close PM;
1371
1372
1373 if( ! $opt_X ){ # print XS, unless it is disabled
1374 warn "Writing $ext$modpname/$modfname.xs\n";
1375
1376 print XS <<"END";
1377 #include "EXTERN.h"
1378 #include "perl.h"
1379 #include "XSUB.h"
1380
1381 END
1382
1383 print XS <<"END" unless $skip_ppport;
1384 #include "ppport.h"
1385
1386 END
1387
1388 if( @path_h ){
1389     foreach my $path_h (@path_h_ini) {
1390         my($h) = $path_h;
1391         $h =~ s#^/usr/include/##;
1392         if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
1393         print XS qq{#include <$h>\n};
1394     }
1395     print XS "\n";
1396 }
1397
1398 print XS <<"END" if $opt_g;
1399
1400 /* Global Data */
1401
1402 #define MY_CXT_KEY "${module}::_guts" XS_VERSION
1403
1404 typedef struct {
1405     /* Put Global Data in here */
1406     int dummy;          /* you can access this elsewhere as MY_CXT.dummy */
1407 } my_cxt_t;
1408
1409 START_MY_CXT
1410
1411 END
1412
1413 my %pointer_typedefs;
1414 my %struct_typedefs;
1415
1416 sub td_is_pointer {
1417   my $type = shift;
1418   my $out = $pointer_typedefs{$type};
1419   return $out if defined $out;
1420   my $otype = $type;
1421   $out = ($type =~ /\*$/);
1422   # This converts only the guys which do not have trailing part in the typedef
1423   if (not $out
1424       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1425     $type = normalize_type($type);
1426     print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1427       if $opt_d;
1428     $out = td_is_pointer($type);
1429   }
1430   return ($pointer_typedefs{$otype} = $out);
1431 }
1432
1433 sub td_is_struct {
1434   my $type = shift;
1435   my $out = $struct_typedefs{$type};
1436   return $out if defined $out;
1437   my $otype = $type;
1438   $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
1439   # This converts only the guys which do not have trailing part in the typedef
1440   if (not $out
1441       and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1442     $type = normalize_type($type);
1443     print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
1444       if $opt_d;
1445     $out = td_is_struct($type);
1446   }
1447   return ($struct_typedefs{$otype} = $out);
1448 }
1449
1450 print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1451
1452 if( ! $opt_c ) {
1453   # We write the "sample" files used when this module is built by perl without
1454   # ExtUtils::Constant.
1455   # h2xs will later check that these are the same as those generated by the
1456   # code embedded into Makefile.PL
1457   unless (-d $fallbackdirname) {
1458     mkdir "$fallbackdirname" or die "Cannot mkdir $fallbackdirname: $!\n";
1459   }
1460   warn "Writing $ext$modpname/$fallbackdirname/$constscfname\n";
1461   warn "Writing $ext$modpname/$fallbackdirname/$constsxsfname\n";
1462   my $cfallback = File::Spec->catfile($fallbackdirname, $constscfname);
1463   my $xsfallback = File::Spec->catfile($fallbackdirname, $constsxsfname);
1464   WriteConstants ( C_FILE =>       $cfallback,
1465                    XS_FILE =>      $xsfallback,
1466                    DEFAULT_TYPE => $opt_t,
1467                    NAME =>         $module,
1468                    NAMES =>        \@const_names,
1469                  );
1470   print XS "#include \"$constscfname\"\n";
1471 }
1472
1473
1474 my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
1475
1476 # Now switch from C to XS by issuing the first MODULE declaration:
1477 print XS <<"END";
1478
1479 MODULE = $module                PACKAGE = $module               $prefix
1480
1481 END
1482
1483 # If a constant() function was #included then output a corresponding
1484 # XS declaration:
1485 print XS "INCLUDE: $constsxsfname\n" unless $opt_c;
1486
1487 print XS <<"END" if $opt_g;
1488
1489 BOOT:
1490 {
1491     MY_CXT_INIT;
1492     /* If any of the fields in the my_cxt_t struct need
1493        to be initialised, do it here.
1494      */
1495 }
1496
1497 END
1498
1499 foreach (sort keys %const_xsub) {
1500     print XS <<"END";
1501 char *
1502 $_()
1503
1504     CODE:
1505 #ifdef $_
1506         RETVAL = $_;
1507 #else
1508         croak("Your vendor has not defined the $module macro $_");
1509 #endif
1510
1511     OUTPUT:
1512         RETVAL
1513
1514 END
1515 }
1516
1517 my %seen_decl;
1518 my %typemap;
1519
1520 sub print_decl {
1521   my $fh = shift;
1522   my $decl = shift;
1523   my ($type, $name, $args) = @$decl;
1524   return if $seen_decl{$name}++; # Need to do the same for docs as well?
1525
1526   my @argnames = map {$_->[1]} @$args;
1527   my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
1528   if ($opt_k) {
1529     s/^\s*const\b\s*// for @argtypes;
1530   }
1531   my @argarrays = map { $_->[4] || '' } @$args;
1532   my $numargs = @$args;
1533   if ($numargs and $argtypes[-1] eq '...') {
1534     $numargs--;
1535     $argnames[-1] = '...';
1536   }
1537   local $" = ', ';
1538   $type = normalize_type($type, 1);
1539
1540   print $fh <<"EOP";
1541
1542 $type
1543 $name(@argnames)
1544 EOP
1545
1546   for my $arg (0 .. $numargs - 1) {
1547     print $fh <<"EOP";
1548         $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
1549 EOP
1550   }
1551 }
1552
1553 sub print_tievar_subs {
1554   my($fh, $name, $type) = @_;
1555   print $fh <<END;
1556 I32
1557 _get_$name(IV index, SV *sv) {
1558     dSP;
1559     PUSHMARK(SP);
1560     XPUSHs(sv);
1561     PUTBACK;
1562     (void)call_pv("$module\::_get_$name", G_DISCARD);
1563     return (I32)0;
1564 }
1565
1566 I32
1567 _set_$name(IV index, SV *sv) {
1568     dSP;
1569     PUSHMARK(SP);
1570     XPUSHs(sv);
1571     PUTBACK;
1572     (void)call_pv("$module\::_set_$name", G_DISCARD);
1573     return (I32)0;
1574 }
1575
1576 END
1577 }
1578
1579 sub print_tievar_xsubs {
1580   my($fh, $name, $type) = @_;
1581   print $fh <<END;
1582 void
1583 _tievar_$name(sv)
1584         SV* sv
1585     PREINIT:
1586         struct ufuncs uf;
1587     CODE:
1588         uf.uf_val = &_get_$name;
1589         uf.uf_set = &_set_$name;
1590         uf.uf_index = (IV)&_get_$name;
1591         sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1592
1593 void
1594 _get_$name(THIS)
1595         $type THIS = NO_INIT
1596     CODE:
1597         THIS = $name;
1598     OUTPUT:
1599         SETMAGIC: DISABLE
1600         THIS
1601
1602 void
1603 _set_$name(THIS)
1604         $type THIS
1605     CODE:
1606         $name = THIS;
1607
1608 END
1609 }
1610
1611 sub print_accessors {
1612   my($fh, $name, $struct) = @_;
1613   return unless defined $struct && $name !~ /\s|_ANON/;
1614   $name = normalize_type($name);
1615   my $ptrname = normalize_type("$name *");
1616   print $fh <<"EOF";
1617
1618 MODULE = $module                PACKAGE = ${name}               $prefix
1619
1620 $name *
1621 _to_ptr(THIS)
1622         $name THIS = NO_INIT
1623     PROTOTYPE: \$
1624     CODE:
1625         if (sv_derived_from(ST(0), "$name")) {
1626             STRLEN len;
1627             char *s = SvPV((SV*)SvRV(ST(0)), len);
1628             if (len != sizeof(THIS))
1629                 croak("Size \%d of packed data != expected \%d",
1630                         len, sizeof(THIS));
1631             RETVAL = ($name *)s;
1632         }
1633         else
1634             croak("THIS is not of type $name");
1635     OUTPUT:
1636         RETVAL
1637
1638 $name
1639 new(CLASS)
1640         char *CLASS = NO_INIT
1641     PROTOTYPE: \$
1642     CODE:
1643         Zero((void*)&RETVAL, sizeof(RETVAL), char);
1644     OUTPUT:
1645         RETVAL
1646
1647 MODULE = $module                PACKAGE = ${name}Ptr            $prefix
1648
1649 EOF
1650   my @items = @$struct;
1651   while (@items) {
1652     my $item = shift @items;
1653     if ($item->[0] =~ /_ANON/) {
1654       if (defined $item->[2]) {
1655         push @items, map [
1656           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1657         ], @{ $structs{$item->[0]} };
1658       } else {
1659         push @items, @{ $structs{$item->[0]} };
1660       }
1661     } else {
1662       my $type = normalize_type($item->[0]);
1663       my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
1664       print $fh <<"EOF";
1665 $ttype
1666 $item->[2](THIS, __value = NO_INIT)
1667         $ptrname THIS
1668         $type __value
1669     PROTOTYPE: \$;\$
1670     CODE:
1671         if (items > 1)
1672             THIS->$item->[-1] = __value;
1673         RETVAL = @{[
1674             $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1675         ]};
1676     OUTPUT:
1677         RETVAL
1678
1679 EOF
1680     }
1681   }
1682 }
1683
1684 sub accessor_docs {
1685   my($name, $struct) = @_;
1686   return unless defined $struct && $name !~ /\s|_ANON/;
1687   $name = normalize_type($name);
1688   my $ptrname = $name . 'Ptr';
1689   my @items = @$struct;
1690   my @list;
1691   while (@items) {
1692     my $item = shift @items;
1693     if ($item->[0] =~ /_ANON/) {
1694       if (defined $item->[2]) {
1695         push @items, map [
1696           @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1697         ], @{ $structs{$item->[0]} };
1698       } else {
1699         push @items, @{ $structs{$item->[0]} };
1700       }
1701     } else {
1702       push @list, $item->[2];
1703     }
1704   }
1705   my $methods = (join '(...)>, C<', @list) . '(...)';
1706
1707   my $pod = <<"EOF";
1708 #
1709 #=head2 Object and class methods for C<$name>/C<$ptrname>
1710 #
1711 #The principal Perl representation of a C object of type C<$name> is an
1712 #object of class C<$ptrname> which is a reference to an integer
1713 #representation of a C pointer.  To create such an object, one may use
1714 #a combination
1715 #
1716 #  my \$buffer = $name->new();
1717 #  my \$obj = \$buffer->_to_ptr();
1718 #
1719 #This exersizes the following two methods, and an additional class
1720 #C<$name>, the internal representation of which is a reference to a
1721 #packed string with the C structure.  Keep in mind that \$buffer should
1722 #better survive longer than \$obj.
1723 #
1724 #=over
1725 #
1726 #=item C<\$object_of_type_$name-E<gt>_to_ptr()>
1727 #
1728 #Converts an object of type C<$name> to an object of type C<$ptrname>.
1729 #
1730 #=item C<$name-E<gt>new()>
1731 #
1732 #Creates an empty object of type C<$name>.  The corresponding packed
1733 #string is zeroed out.
1734 #
1735 #=item C<$methods>
1736 #
1737 #return the current value of the corresponding element if called
1738 #without additional arguments.  Set the element to the supplied value
1739 #(and return the new value) if called with an additional argument.
1740 #
1741 #Applicable to objects of type C<$ptrname>.
1742 #
1743 #=back
1744 #
1745 EOF
1746   $pod =~ s/^\#//gm;
1747   return $pod;
1748 }
1749
1750 # Should be called before any actual call to normalize_type().
1751 sub get_typemap {
1752   # We do not want to read ./typemap by obvios reasons.
1753   my @tm =  qw(../../../typemap ../../typemap ../typemap);
1754   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
1755   unshift @tm, $stdtypemap;
1756   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
1757
1758   # Start with useful default values
1759   $typemap{float} = 'T_NV';
1760
1761   foreach my $typemap (@tm) {
1762     next unless -e $typemap ;
1763     # skip directories, binary files etc.
1764     warn " Scanning $typemap\n";
1765     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1766       unless -T $typemap ;
1767     open(TYPEMAP, $typemap)
1768       or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1769     my $mode = 'Typemap';
1770     while (<TYPEMAP>) {
1771       next if /^\s*\#/;
1772       if (/^INPUT\s*$/)   { $mode = 'Input'; next; }
1773       elsif (/^OUTPUT\s*$/)  { $mode = 'Output'; next; }
1774       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1775       elsif ($mode eq 'Typemap') {
1776         next if /^\s*($|\#)/ ;
1777         my ($type, $image);
1778         if ( ($type, $image) =
1779              /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1780              # This may reference undefined functions:
1781              and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
1782           $typemap{normalize_type($type)} = $image;
1783         }
1784       }
1785     }
1786     close(TYPEMAP) or die "Cannot close $typemap: $!";
1787   }
1788   %std_types = %types_seen;
1789   %types_seen = ();
1790 }
1791
1792
1793 sub normalize_type {            # Second arg: do not strip const's before \*
1794   my $type = shift;
1795   my $do_keep_deep_const = shift;
1796   # If $do_keep_deep_const this is heuristical only
1797   my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
1798   my $ignore_mods
1799     = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1800   if ($do_keep_deep_const) {    # Keep different compiled /RExen/o separately!
1801     $type =~ s/$ignore_mods//go;
1802   }
1803   else {
1804     $type =~ s/$ignore_mods//go;
1805   }
1806   $type =~ s/([^\s\w])/ $1 /g;
1807   $type =~ s/\s+$//;
1808   $type =~ s/^\s+//;
1809   $type =~ s/\s+/ /g;
1810   $type =~ s/\* (?=\*)/*/g;
1811   $type =~ s/\. \. \./.../g;
1812   $type =~ s/ ,/,/g;
1813   $types_seen{$type}++
1814     unless $type eq '...' or $type eq 'void' or $std_types{$type};
1815   $type;
1816 }
1817
1818 my $need_opaque;
1819
1820 sub assign_typemap_entry {
1821   my $type = shift;
1822   my $otype = $type;
1823   my $entry;
1824   if ($tmask and $type =~ /$tmask/) {
1825     print "Type $type matches -o mask\n" if $opt_d;
1826     $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1827   }
1828   elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1829     $type = normalize_type $type;
1830     print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1831     $entry = assign_typemap_entry($type);
1832   }
1833   # XXX good do better if our UV happens to be long long
1834   return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/;
1835   $entry ||= $typemap{$otype}
1836     || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1837   $typemap{$otype} = $entry;
1838   $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1839   return $entry;
1840 }
1841
1842 for (@vdecls) {
1843   print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
1844 }
1845
1846 if ($opt_x) {
1847   for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1848   if ($opt_a) {
1849     while (my($name, $struct) = each %structs) {
1850       print_accessors(\*XS, $name, $struct);
1851     }
1852   }
1853 }
1854
1855 close XS;
1856
1857 if (%types_seen) {
1858   my $type;
1859   warn "Writing $ext$modpname/typemap\n";
1860   open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1861
1862   for $type (sort keys %types_seen) {
1863     my $entry = assign_typemap_entry $type;
1864     print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
1865   }
1866
1867   print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1868 #############################################################################
1869 INPUT
1870 T_OPAQUE_STRUCT
1871         if (sv_derived_from($arg, \"${ntype}\")) {
1872             STRLEN len;
1873             char  *s = SvPV((SV*)SvRV($arg), len);
1874
1875             if (len != sizeof($var))
1876                 croak(\"Size %d of packed data != expected %d\",
1877                         len, sizeof($var));
1878             $var = *($type *)s;
1879         }
1880         else
1881             croak(\"$var is not of type ${ntype}\")
1882 #############################################################################
1883 OUTPUT
1884 T_OPAQUE_STRUCT
1885         sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1886 EOP
1887
1888   close TM or die "Cannot close typemap file for write: $!";
1889 }
1890
1891 } # if( ! $opt_X )
1892
1893 warn "Writing $ext$modpname/Makefile.PL\n";
1894 open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
1895
1896 my $prereq_pm = '';
1897
1898 if ( $compat_version < 5.00702 and $new_test )
1899 {
1900   $prereq_pm .= q%'Test::More'  =>  0, %;
1901 }
1902
1903 if ( $compat_version < 5.00600 and !$opt_X and $use_xsloader)
1904 {
1905   $prereq_pm .= q%'XSLoader'  =>  0, %;
1906 }
1907
1908 print PL <<"END";
1909 use $compat_version;
1910 use ExtUtils::MakeMaker;
1911 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
1912 # the contents of the Makefile that is written.
1913 WriteMakefile(
1914     NAME              => '$module',
1915     VERSION_FROM      => '$modpmname', # finds \$VERSION
1916     PREREQ_PM         => {$prereq_pm}, # e.g., Module::Name => 1.1
1917     (\$] >= 5.005 ?     ## Add these new keywords supported since 5.005
1918       (ABSTRACT_FROM  => '$modpmname', # retrieve abstract from module
1919        AUTHOR         => '$author <$email>') : ()),
1920 END
1921 if (!$opt_X) { # print C stuff, unless XS is disabled
1922   $opt_F = '' unless defined $opt_F;
1923   my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
1924   my $Ihelp = ($I ? '-I. ' : '');
1925   my $Icomment = ($I ? '' : <<EOC);
1926         # Insert -I. if you add *.h files later:
1927 EOC
1928
1929   print PL <<END;
1930     LIBS              => ['$extralibs'], # e.g., '-lm'
1931     DEFINE            => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1932 $Icomment    INC               => '$I', # e.g., '${Ihelp}-I/usr/include/other'
1933 END
1934
1935   my $C = grep {$_ ne "$modfname.c"}
1936     (glob '*.c'), (glob '*.cc'), (glob '*.C');
1937   my $Cpre = ($C ? '' : '# ');
1938   my $Ccomment = ($C ? '' : <<EOC);
1939         # Un-comment this if you add C files to link with later:
1940 EOC
1941
1942   print PL <<END;
1943 $Ccomment    ${Cpre}OBJECT            => '\$(O_FILES)', # link all the C files too
1944 END
1945 } # ' # Grr
1946 print PL ");\n";
1947 if (!$opt_c) {
1948   my $generate_code =
1949     WriteMakefileSnippet ( C_FILE =>       $constscfname,
1950                            XS_FILE =>      $constsxsfname,
1951                            DEFAULT_TYPE => $opt_t,
1952                            NAME =>         $module,
1953                            NAMES =>        \@const_names,
1954                  );
1955   print PL <<"END";
1956 if  (eval {require ExtUtils::Constant; 1}) {
1957   # If you edit these definitions to change the constants used by this module,
1958   # you will need to use the generated $constscfname and $constsxsfname
1959   # files to replace their "fallback" counterparts before distributing your
1960   # changes.
1961 $generate_code
1962 }
1963 else {
1964   use File::Copy;
1965   use File::Spec;
1966   foreach my \$file ('$constscfname', '$constsxsfname') {
1967     my \$fallback = File::Spec->catfile('$fallbackdirname', \$file);
1968     copy (\$fallback, \$file) or die "Can't copy \$fallback to \$file: \$!";
1969   }
1970 }
1971 END
1972
1973   eval $generate_code;
1974   if ($@) {
1975     warn <<"EOM";
1976 Attempting to test constant code in $ext$modpname/Makefile.PL:
1977 $generate_code
1978 __END__
1979 gave unexpected error $@
1980 Please report the circumstances of this bug in h2xs version $H2XS_VERSION
1981 using the perlbug script.
1982 EOM
1983   } else {
1984     my $fail;
1985
1986     foreach my $file ($constscfname, $constsxsfname) {
1987       my $fallback = File::Spec->catfile($fallbackdirname, $file);
1988       if (compare($file, $fallback)) {
1989         warn << "EOM";
1990 Files "$ext$modpname/$fallbackdirname/$file" and "$ext$modpname/$file" differ.
1991 EOM
1992         $fail++;
1993       }
1994     }
1995     if ($fail) {
1996       warn fill ('','', <<"EOM") . "\n";
1997 It appears that the code in $ext$modpname/Makefile.PL does not autogenerate
1998 the files $ext$modpname/$constscfname and $ext$modpname/$constsxsfname
1999 correctly.
2000
2001 Please report the circumstances of this bug in h2xs version $H2XS_VERSION
2002 using the perlbug script.
2003 EOM
2004     } else {
2005       unlink $constscfname, $constsxsfname;
2006     }
2007   }
2008 }
2009 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
2010
2011 # Create a simple README since this is a CPAN requirement
2012 # and it doesnt hurt to have one
2013 warn "Writing $ext$modpname/README\n";
2014 open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
2015 my $thisyear = (gmtime)[5] + 1900;
2016 my $rmhead = "$modpname version $TEMPLATE_VERSION";
2017 my $rmheadeq = "=" x length($rmhead);
2018
2019 my $rm_prereq;
2020
2021 if ( $compat_version < 5.00702 and $new_test )
2022 {
2023    $rm_prereq = 'Test::More';
2024 }
2025 else
2026 {
2027    $rm_prereq = 'blah blah blah';
2028 }
2029
2030 print RM <<_RMEND_;
2031 $rmhead
2032 $rmheadeq
2033
2034 The README is used to introduce the module and provide instructions on
2035 how to install the module, any machine dependencies it may have (for
2036 example C compilers and installed libraries) and any other information
2037 that should be provided before the module is installed.
2038
2039 A README file is required for CPAN modules since CPAN extracts the
2040 README file from a module distribution so that people browsing the
2041 archive can use it get an idea of the modules uses. It is usually a
2042 good idea to provide version information here so that people can
2043 decide whether fixes for the module are worth downloading.
2044
2045 INSTALLATION
2046
2047 To install this module type the following:
2048
2049    perl Makefile.PL
2050    make
2051    make test
2052    make install
2053
2054 DEPENDENCIES
2055
2056 This module requires these other modules and libraries:
2057
2058   $rm_prereq
2059
2060 COPYRIGHT AND LICENCE
2061
2062 Put the correct copyright and licence information here.
2063
2064 $licence
2065
2066 _RMEND_
2067 close(RM) || die "Can't close $ext$modpname/README: $!\n";
2068
2069 my $testdir  = "t";
2070 my $testfile = "$testdir/$modpname.t";
2071 unless (-d "$testdir") {
2072   mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n";
2073 }
2074 warn "Writing $ext$modpname/$testfile\n";
2075 my $tests = @const_names ? 2 : 1;
2076
2077 open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n";
2078
2079 print EX <<_END_;
2080 # Before `make install' is performed this script should be runnable with
2081 # `make test'. After `make install' it should work as `perl $modpname.t'
2082
2083 #########################
2084
2085 # change 'tests => $tests' to 'tests => last_test_to_print';
2086
2087 _END_
2088
2089 my $test_mod = 'Test::More';
2090
2091 if ( $old_test or ($compat_version < 5.007 and not $new_test ))
2092 {
2093   my $test_mod = 'Test';
2094
2095   print EX <<_END_;
2096 use Test;
2097 BEGIN { plan tests => $tests };
2098 use $module;
2099 ok(1); # If we made it this far, we're ok.
2100
2101 _END_
2102
2103    if (@const_names) {
2104      my $const_names = join " ", @const_names;
2105      print EX <<'_END_';
2106
2107 my $fail;
2108 foreach my $constname (qw(
2109 _END_
2110
2111      print EX wrap ("\t", "\t", $const_names);
2112      print EX (")) {\n");
2113
2114      print EX <<_END_;
2115   next if (eval "my \\\$a = \$constname; 1");
2116   if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
2117     print "# pass: \$\@";
2118   } else {
2119     print "# fail: \$\@";
2120     \$fail = 1;
2121   }
2122 }
2123 if (\$fail) {
2124   print "not ok 2\\n";
2125 } else {
2126   print "ok 2\\n";
2127 }
2128
2129 _END_
2130   }
2131 }
2132 else
2133 {
2134   print EX <<_END_;
2135 use Test::More tests => $tests;
2136 BEGIN { use_ok('$module') };
2137
2138 _END_
2139
2140    if (@const_names) {
2141      my $const_names = join " ", @const_names;
2142      print EX <<'_END_';
2143
2144 my $fail = 0;
2145 foreach my $constname (qw(
2146 _END_
2147
2148      print EX wrap ("\t", "\t", $const_names);
2149      print EX (")) {\n");
2150
2151      print EX <<_END_;
2152   next if (eval "my \\\$a = \$constname; 1");
2153   if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
2154     print "# pass: \$\@";
2155   } else {
2156     print "# fail: \$\@";
2157     \$fail = 1;
2158   }
2159
2160 }
2161
2162 ok( \$fail == 0 , 'Constants' );
2163 _END_
2164   }
2165 }
2166
2167 print EX <<_END_;
2168 #########################
2169
2170 # Insert your test code below, the $test_mod module is use()ed here so read
2171 # its man page ( perldoc $test_mod ) for help writing this test script.
2172
2173 _END_
2174
2175 close(EX) || die "Can't close $ext$modpname/$testfile: $!\n";
2176
2177 unless ($opt_C) {
2178   warn "Writing $ext$modpname/Changes\n";
2179   $" = ' ';
2180   open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
2181   @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
2182   print EX <<EOP;
2183 Revision history for Perl extension $module.
2184
2185 $TEMPLATE_VERSION  @{[scalar localtime]}
2186 \t- original version; created by h2xs $H2XS_VERSION with options
2187 \t\t@ARGS
2188
2189 EOP
2190   close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
2191 }
2192
2193 warn "Writing $ext$modpname/MANIFEST\n";
2194 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
2195 my @files = grep { -f } (<*>, <t/*>, <$fallbackdirname/*>, <$modpmdir/*>);
2196 if (!@files) {
2197   eval {opendir(D,'.');};
2198   unless ($@) { @files = readdir(D); closedir(D); }
2199 }
2200 if (!@files) { @files = map {chomp && $_} `ls`; }
2201 if ($^O eq 'VMS') {
2202   foreach (@files) {
2203     # Clip trailing '.' for portability -- non-VMS OSs don't expect it
2204     s%\.$%%;
2205     # Fix up for case-sensitive file systems
2206     s/$modfname/$modfname/i && next;
2207     $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
2208     $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
2209   }
2210 }
2211 print MANI join("\n",@files), "\n";
2212 close MANI;
2213 !NO!SUBS!
2214
2215 close OUT or die "Can't close $file: $!";
2216 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
2217 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
2218 chdir $origdir;