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