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