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