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