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