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