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