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