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