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