This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH: perl@11564] introducing perlivp
[perl5.git] / utils / h2xs.PL
CommitLineData
4633a7c4
LW
1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
8a5546a1 5use Cwd;
4633a7c4
LW
6
7# List explicitly here the variables you want Configure to
8# generate. Metaconfig only looks for shell variables, so you
9# have to mention them as if they were shell variables, not
10# %Config entries. Thus you write
11# $startperl
12# to ensure Configure will look for $Config{startperl}.
13
14# This forces PL files to create target in same directory as PL file.
15# This is so that make depend always knows where to find PL derivatives.
be3174d2 16my $origdir = cwd;
44a8e56a 17chdir dirname($0);
be3174d2 18my $file = basename($0, '.PL');
774d564b 19$file .= '.com' if $^O eq 'VMS';
4633a7c4
LW
20
21open OUT,">$file" or die "Can't create $file: $!";
22
23print "Extracting $file (with variable substitutions)\n";
24
25# In this section, perl variables will be expanded during extraction.
26# You can use $Config{...} to use Configure variables.
27
28print OUT <<"!GROK!THIS!";
1dea8210 29$Config{startperl}
5f05dabc
PP
30 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
31 if \$running_under_some_shell;
40000a8c
AD
32!GROK!THIS!
33
4633a7c4
LW
34# In the following, perl variables are not expanded during extraction.
35
36print OUT <<'!NO!SUBS!';
cf35f3c1 37
1dea8210
JH
38use warnings;
39
3edbfbe5
TB
40=head1 NAME
41
42h2xs - convert .h C header files to Perl extensions
43
44=head1 SYNOPSIS
45
11946041 46B<h2xs> [B<OPTIONS> ...] [headerfile ... [extra_libraries]]
f508c652 47
11946041 48B<h2xs> B<-h>|B<-?>|B<--help>
3edbfbe5
TB
49
50=head1 DESCRIPTION
51
a887ff11
BS
52I<h2xs> builds a Perl extension from C header files. The extension
53will include functions which can be used to retrieve the value of any
54#define statement which was in the C header files.
3edbfbe5
TB
55
56The I<module_name> will be used for the name of the extension. If
a887ff11
BS
57module_name is not supplied then the name of the first header file
58will be used, with the first character capitalized.
3edbfbe5
TB
59
60If the extension might need extra libraries, they should be included
61here. The extension Makefile.PL will take care of checking whether
9cacc32e
JH
62the libraries actually exist and how they should be loaded. The extra
63libraries should be specified in the form -lm -lposix, etc, just as on
64the cc command line. By default, the Makefile.PL will search through
65the library path determined by Configure. That path can be augmented
66by including arguments of the form B<-L/another/library/path> in the
67extra-libraries argument.
3edbfbe5
TB
68
69=head1 OPTIONS
70
71=over 5
72
4d2d0db2 73=item B<-A>, B<--omit-autoload>
3edbfbe5 74
9cacc32e
JH
75Omit all autoload facilities. This is the same as B<-c> but also
76removes the S<C<use AutoLoader>> statement from the .pm file.
3edbfbe5 77
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
e1666bf5 743
a0d0e21e 744
3cb4da91 745my ($ext, $nested, @modparts, $modfname, $modpname);
f1f595f5
JS
746
747$ext = chdir 'ext' ? 'ext/' : '';
a0d0e21e
LW
748
749if( $module =~ /::/ ){
750 $nested = 1;
751 @modparts = split(/::/,$module);
752 $modfname = $modparts[-1];
753 $modpname = join('/',@modparts);
754}
755else {
756 $nested = 0;
757 @modparts = ();
758 $modfname = $modpname = $module;
759}
760
761
2920c5d2
PP
762if ($opt_O) {
763 warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
7aff18a2
GS
764}
765else {
2920c5d2
PP
766 die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
767}
c07a80fd 768if( $nested ){
3cb4da91 769 my $modpath = "";
c07a80fd 770 foreach (@modparts){
e42bd63e 771 -d "$modpath$_" || mkdir("$modpath$_", 0777);
c07a80fd
PP
772 $modpath .= "$_/";
773 }
774}
e42bd63e 775-d "$modpname" || mkdir($modpname, 0777);
8e07c86e 776chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
a0d0e21e 777
5273d82d
IZ
778my %types_seen;
779my %std_types;
f4d63e4e
IZ
780my $fdecls = [];
781my $fdecls_parsed = [];
ddf6bed1
IZ
782my $typedef_rex;
783my %typedefs_pre;
784my %known_fnames;
7c1d48a5 785my %structs;
5273d82d 786
3cb4da91
IZ
787my @fnames;
788my @fnames_no_prefix;
32fb2b78
GS
789my %vdecl_hash;
790my @vdecls;
5273d82d 791
2920c5d2
PP
792if( ! $opt_X ){ # use XS, unless it was disabled
793 open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
5273d82d 794 if ($opt_x) {
5273d82d
IZ
795 require Config; # Run-time directive
796 warn "Scanning typemaps...\n";
797 get_typemap();
3cb4da91
IZ
798 my @td;
799 my @good_td;
800 my $addflags = $opt_F || '';
801
f4d63e4e 802 foreach my $filename (@path_h) {
3cb4da91
IZ
803 my $c;
804 my $filter;
805
806 if ($fullpath{$filename} =~ /,/) {
f4d63e4e
IZ
807 $filename = $`;
808 $filter = $';
809 }
810 warn "Scanning $filename for functions...\n";
5ce74a3d 811 my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X);
f4d63e4e 812 $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
5ce74a3d 813 'add_cppflags' => $addflags, 'c_styles' => \@styles;
f4d63e4e 814 $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
ddf6bed1 815
f4d63e4e
IZ
816 push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
817 push(@$fdecls, @{$c->get('fdecls')});
3cb4da91
IZ
818
819 push @td, @{$c->get('typedefs_maybe')};
7c1d48a5
GS
820 if ($opt_a) {
821 my $structs = $c->get('typedef_structs');
822 @structs{keys %$structs} = values %$structs;
823 }
3cb4da91 824
32fb2b78
GS
825 if ($opt_m) {
826 %vdecl_hash = %{ $c->get('vdecl_hash') };
827 @vdecls = sort keys %vdecl_hash;
828 for (local $_ = 0; $_ < @vdecls; ++$_) {
829 my $var = $vdecls[$_];
830 my($type, $post) = @{ $vdecl_hash{$var} };
831 if (defined $post) {
832 warn "Can't handle variable '$type $var $post', skipping.\n";
833 splice @vdecls, $_, 1;
834 redo;
835 }
836 $type = normalize_type($type);
837 $vdecl_hash{$var} = $type;
838 }
839 }
840
3cb4da91
IZ
841 unless ($tmask_all) {
842 warn "Scanning $filename for typedefs...\n";
843 my $td = $c->get('typedef_hash');
844 # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
845 my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
846 push @good_td, @f_good_td;
847 @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td};
848 }
849 }
850 { local $" = '|';
6542b28e 851 $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
5273d82d 852 }
ddf6bed1
IZ
853 %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
854 if ($fmask) {
855 my @good;
856 for my $i (0..$#$fdecls_parsed) {
857 next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
858 push @good, $i;
859 print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
860 if $opt_d;
861 }
862 $fdecls = [@$fdecls[@good]];
863 $fdecls_parsed = [@$fdecls_parsed[@good]];
864 }
3cb4da91
IZ
865 @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
866 # Sort declarations:
867 {
868 my %h = map( ($_->[1], $_), @$fdecls_parsed);
869 $fdecls_parsed = [ @h{@fnames} ];
ddf6bed1 870 }
3cb4da91
IZ
871 @fnames_no_prefix = @fnames;
872 @fnames_no_prefix
873 = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix;
ddf6bed1 874 # Remove macros which expand to typedefs
ddf6bed1
IZ
875 print "Typedefs are @td.\n" if $opt_d;
876 my %td = map {($_, $_)} @td;
877 # Add some other possible but meaningless values for macros
878 for my $k (qw(char double float int long short unsigned signed void)) {
879 $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
880 }
881 # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
882 my $n = 0;
883 my %bad_macs;
884 while (keys %td > $n) {
885 $n = keys %td;
886 my ($k, $v);
887 while (($k, $v) = each %seen_define) {
888 # print("found '$k'=>'$v'\n"),
889 $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
890 }
891 }
892 # Now %bad_macs contains names of bad macros
893 for my $k (keys %bad_macs) {
894 delete $const_names{$prefixless{$k}};
895 print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
5273d82d 896 }
5273d82d 897 }
2920c5d2 898}
3cb4da91 899my @const_names = sort keys %const_names;
5273d82d 900
8e07c86e 901open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
a0d0e21e 902
a0d0e21e 903$" = "\n\t";
8e07c86e 904warn "Writing $ext$modpname/$modfname.pm\n";
a0d0e21e 905
be3174d2
GS
906if ( $compat_version < 5.006 ) {
907print PM <<"END";
908package $module;
909
910use $compat_version;
911use strict;
912END
913}
914else {
a0d0e21e
LW
915print PM <<"END";
916package $module;
917
be573f63 918use 5.006;
2920c5d2 919use strict;
8cd79558 920use warnings;
2920c5d2 921END
be3174d2 922}
2920c5d2 923
aba05478 924unless( $opt_X || $opt_c || $opt_A ){
2920c5d2
PP
925 # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
926 # will want Carp.
927 print PM <<'END';
928use Carp;
2920c5d2
PP
929END
930}
931
932print PM <<'END';
933
a0d0e21e 934require Exporter;
2920c5d2
PP
935END
936
937print PM <<"END" if ! $opt_X; # use DynaLoader, unless XS was disabled
a0d0e21e 938require DynaLoader;
3edbfbe5
TB
939END
940
e1666bf5 941
9ef261b5
MS
942# Are we using AutoLoader or not?
943unless ($opt_A) { # no autoloader whatsoever.
944 unless ($opt_c) { # we're doing the AUTOLOAD
945 print PM "use AutoLoader;\n";
2920c5d2 946 }
9ef261b5
MS
947 else {
948 print PM "use AutoLoader qw(AUTOLOAD);\n"
2920c5d2 949 }
3edbfbe5 950}
3edbfbe5 951
be3174d2
GS
952if ( $compat_version < 5.006 ) {
953 if ( $opt_X || $opt_c || $opt_A ) {
954 print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);';
955 } else {
956 print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);';
957 }
958}
959
9ef261b5 960# Determine @ISA.
77ca0c92 961my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this.
9ef261b5
MS
962$myISA .= ' DynaLoader' unless $opt_X; # no XS
963$myISA .= ');';
be3174d2
GS
964$myISA =~ s/^our // if $compat_version < 5.006;
965
9ef261b5 966print PM "\n$myISA\n\n";
e1666bf5 967
32fb2b78 968my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
3cb4da91 969
be3174d2 970my $tmp=<<"END";
e1666bf5
TB
971# Items to export into callers namespace by default. Note: do not export
972# names by default without a very good reason. Use EXPORT_OK instead.
973# Do not simply export all your public functions/methods/constants.
ddf6bed1
IZ
974
975# This allows declaration use $module ':all';
976# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
977# will save memory.
51fac20b 978our %EXPORT_TAGS = ( 'all' => [ qw(
3cb4da91 979 @exported_names
ddf6bed1
IZ
980) ] );
981
51fac20b 982our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
ddf6bed1 983
77ca0c92 984our \@EXPORT = qw(
e1666bf5 985 @const_names
a0d0e21e 986);
77ca0c92 987our \$VERSION = '$TEMPLATE_VERSION';
f508c652 988
e1666bf5
TB
989END
990
be3174d2
GS
991$tmp =~ s/^our //mg if $compat_version < 5.006;
992print PM $tmp;
993
32fb2b78
GS
994if (@vdecls) {
995 printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
996}
997
be3174d2 998
af6c647e 999print PM autoload ($module, $compat_version) unless $opt_c or $opt_X;
a0d0e21e 1000
2920c5d2
PP
1001if( ! $opt_X ){ # print bootstrap, unless XS is disabled
1002 print PM <<"END";
f508c652 1003bootstrap $module \$VERSION;
2920c5d2
PP
1004END
1005}
1006
32fb2b78
GS
1007# tying the variables can happen only after bootstrap
1008if (@vdecls) {
1009 printf PM <<END;
1010{
1011@{[ join "\n", map " _tievar_$_(\$$_);", @vdecls ]}
1012}
1013
1014END
1015}
1016
3cb4da91 1017my $after;
2920c5d2
PP
1018if( $opt_P ){ # if POD is disabled
1019 $after = '__END__';
1020}
1021else {
1022 $after = '=cut';
1023}
1024
1025print PM <<"END";
a0d0e21e 1026
e1666bf5 1027# Preloaded methods go here.
9ef261b5
MS
1028END
1029
1030print PM <<"END" unless $opt_A;
a0d0e21e 1031
2920c5d2 1032# Autoload methods go after $after, and are processed by the autosplit program.
9ef261b5
MS
1033END
1034
1035print PM <<"END";
a0d0e21e
LW
1036
10371;
e1666bf5 1038__END__
a0d0e21e 1039END
a0d0e21e 1040
65cf46c7
JS
1041my ($email,$author);
1042
1043eval {
1044 my $user;
1045 ($user,$author) = (getpwuid($>))[0,6];
1046 $author =~ s/,.*$//; # in case of sub fields
1047 my $domain = $Config{'mydomain'};
1048 $domain =~ s/^\.//;
1049 $email = "$user\@$domain";
1050 };
1051
1052$author ||= "A. U. Thor";
1053$email ||= 'a.u.thor@a.galaxy.far.far.away';
f508c652 1054
c0f8b9cd
GS
1055my $revhist = '';
1056$revhist = <<EOT if $opt_C;
497711e7
GS
1057#
1058#=head1 HISTORY
1059#
1060#=over 8
1061#
1062#=item $TEMPLATE_VERSION
1063#
1064#Original version; created by h2xs $H2XS_VERSION with options
1065#
1066# @ARGS
1067#
1068#=back
1069#
c0f8b9cd
GS
1070EOT
1071
ddf6bed1 1072my $exp_doc = <<EOD;
497711e7
GS
1073#
1074#=head2 EXPORT
1075#
1076#None by default.
1077#
ddf6bed1 1078EOD
b7d5fa84 1079
5273d82d 1080if (@const_names and not $opt_P) {
ddf6bed1 1081 $exp_doc .= <<EOD;
497711e7
GS
1082#=head2 Exportable constants
1083#
1084# @{[join "\n ", @const_names]}
1085#
5273d82d
IZ
1086EOD
1087}
b7d5fa84 1088
5273d82d 1089if (defined $fdecls and @$fdecls and not $opt_P) {
ddf6bed1 1090 $exp_doc .= <<EOD;
497711e7
GS
1091#=head2 Exportable functions
1092#
3cb4da91 1093EOD
b7d5fa84 1094
497711e7
GS
1095# $exp_doc .= <<EOD if $opt_p;
1096#When accessing these functions from Perl, prefix C<$opt_p> should be removed.
1097#
b7d5fa84 1098#EOD
3cb4da91 1099 $exp_doc .= <<EOD;
497711e7
GS
1100# @{[join "\n ", @known_fnames{@fnames}]}
1101#
5273d82d
IZ
1102EOD
1103}
1104
b7d5fa84
IZ
1105my $meth_doc = '';
1106
1107if ($opt_x && $opt_a) {
1108 my($name, $struct);
1109 $meth_doc .= accessor_docs($name, $struct)
1110 while ($name, $struct) = each %structs;
1111}
1112
3cb4da91 1113my $pod = <<"END" unless $opt_P;
7aff18a2 1114## Below is stub documentation for your module. You better edit it!
f508c652
PP
1115#
1116#=head1 NAME
1117#
1118#$module - Perl extension for blah blah blah
1119#
1120#=head1 SYNOPSIS
1121#
1122# use $module;
1123# blah blah blah
1124#
11946041
JS
1125#=head1 ABSTRACT
1126#
1127# This should be the abstract for $module.
1128# The abstract is used when making PPD (Perl Package Description) files.
1129# If you don't want an ABSTRACT you should also edit Makefile.PL to
1130# remove the ABSTRACT_FROM option.
1131#
f508c652
PP
1132#=head1 DESCRIPTION
1133#
7aff18a2 1134#Stub documentation for $module, created by h2xs. It looks like the
f508c652
PP
1135#author of the extension was negligent enough to leave the stub
1136#unedited.
1137#
1138#Blah blah blah.
b7d5fa84 1139$exp_doc$meth_doc$revhist
f508c652 1140#
09c48e64 1141#=head1 SEE ALSO
f508c652 1142#
09c48e64
JH
1143#Mention other useful documentation such as the documentation of
1144#related modules or operating system documentation (such as man pages
1145#in UNIX), or any relevant external documentation such as RFCs or
1146#standards.
e8f26592
EHA
1147#
1148#If you have a mailing list set up for your module, mention it here.
1149#
09c48e64
JH
1150#If you have a web site set up for your module, mention it here.
1151#
1152#=head1 AUTHOR
1153#
1154#$author, E<lt>${email}E<gt>
1155#
e8f26592
EHA
1156#=head1 COPYRIGHT AND LICENSE
1157#
380e3302 1158#Copyright ${\(1900 + (localtime) [5])} by $author
e8f26592
EHA
1159#
1160#This library is free software; you can redistribute it and/or modify
1161#it under the same terms as Perl itself.
1162#
f508c652
PP
1163#=cut
1164END
1165
1166$pod =~ s/^\#//gm unless $opt_P;
1167print PM $pod unless $opt_P;
1168
a0d0e21e
LW
1169close PM;
1170
e1666bf5 1171
2920c5d2 1172if( ! $opt_X ){ # print XS, unless it is disabled
8e07c86e 1173warn "Writing $ext$modpname/$modfname.xs\n";
e1666bf5 1174
a0d0e21e
LW
1175print XS <<"END";
1176#include "EXTERN.h"
1177#include "perl.h"
1178#include "XSUB.h"
1179
1180END
a887ff11 1181if( @path_h ){
3cb4da91 1182 foreach my $path_h (@path_h_ini) {
a0d0e21e
LW
1183 my($h) = $path_h;
1184 $h =~ s#^/usr/include/##;
ead2a595 1185 if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
a887ff11
BS
1186 print XS qq{#include <$h>\n};
1187 }
1188 print XS "\n";
a0d0e21e
LW
1189}
1190
ddf6bed1
IZ
1191my %pointer_typedefs;
1192my %struct_typedefs;
1193
1194sub td_is_pointer {
1195 my $type = shift;
1196 my $out = $pointer_typedefs{$type};
1197 return $out if defined $out;
1198 my $otype = $type;
1199 $out = ($type =~ /\*$/);
1200 # This converts only the guys which do not have trailing part in the typedef
1201 if (not $out
1202 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1203 $type = normalize_type($type);
1204 print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
1205 if $opt_d;
1206 $out = td_is_pointer($type);
1207 }
1208 return ($pointer_typedefs{$otype} = $out);
1209}
1210
1211sub td_is_struct {
1212 my $type = shift;
1213 my $out = $struct_typedefs{$type};
1214 return $out if defined $out;
1215 my $otype = $type;
32fb2b78 1216 $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
ddf6bed1
IZ
1217 # This converts only the guys which do not have trailing part in the typedef
1218 if (not $out
1219 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1220 $type = normalize_type($type);
1221 print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
1222 if $opt_d;
1223 $out = td_is_struct($type);
1224 }
1225 return ($struct_typedefs{$otype} = $out);
1226}
1227
af6c647e
NC
1228my $types = {};
1229# Important. Passing an undef scalar doesn't cause the
1230# autovivified hashref to appear back out in this scope.
e1666bf5 1231
ddf6bed1 1232if( ! $opt_c ) {
af6c647e 1233 print XS constant_types(), "\n";
181f5113
NC
1234 foreach (C_constant ($module, undef, $opt_t, $types, undef, undef,
1235 @const_names)) {
af6c647e
NC
1236 print XS $_, "\n";
1237 }
e1666bf5
TB
1238}
1239
32fb2b78
GS
1240print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
1241
f1f595f5 1242my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
3cb4da91 1243
e1666bf5
TB
1244# Now switch from C to XS by issuing the first MODULE declaration:
1245print XS <<"END";
a0d0e21e 1246
ead2a595
PP
1247MODULE = $module PACKAGE = $module $prefix
1248
1249END
1250
1251foreach (sort keys %const_xsub) {
1252 print XS <<"END";
1253char *
1254$_()
1255
1256 CODE:
1257#ifdef $_
7aff18a2 1258 RETVAL = $_;
ead2a595 1259#else
7aff18a2 1260 croak("Your vendor has not defined the $module macro $_");
ead2a595
PP
1261#endif
1262
1263 OUTPUT:
7aff18a2 1264 RETVAL
a0d0e21e 1265
e1666bf5 1266END
ead2a595 1267}
e1666bf5
TB
1268
1269# If a constant() function was written then output a corresponding
1270# XS declaration:
af6c647e
NC
1271# XXX IVs
1272print XS XS_constant ($module, $types) unless $opt_c;
a0d0e21e 1273
5273d82d 1274my %seen_decl;
ddf6bed1 1275my %typemap;
5273d82d 1276
ead2a595
PP
1277sub print_decl {
1278 my $fh = shift;
1279 my $decl = shift;
1280 my ($type, $name, $args) = @$decl;
5273d82d
IZ
1281 return if $seen_decl{$name}++; # Need to do the same for docs as well?
1282
ead2a595 1283 my @argnames = map {$_->[1]} @$args;
ddf6bed1 1284 my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
32fb2b78
GS
1285 if ($opt_k) {
1286 s/^\s*const\b\s*// for @argtypes;
1287 }
5273d82d 1288 my @argarrays = map { $_->[4] || '' } @$args;
ead2a595
PP
1289 my $numargs = @$args;
1290 if ($numargs and $argtypes[-1] eq '...') {
1291 $numargs--;
1292 $argnames[-1] = '...';
1293 }
1294 local $" = ', ';
ddf6bed1
IZ
1295 $type = normalize_type($type, 1);
1296
ead2a595
PP
1297 print $fh <<"EOP";
1298
1299$type
1300$name(@argnames)
1301EOP
1302
3cb4da91 1303 for my $arg (0 .. $numargs - 1) {
ead2a595 1304 print $fh <<"EOP";
5273d82d 1305 $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
ead2a595
PP
1306EOP
1307 }
1308}
1309
32fb2b78
GS
1310sub print_tievar_subs {
1311 my($fh, $name, $type) = @_;
1312 print $fh <<END;
1313I32
1314_get_$name(IV index, SV *sv) {
1315 dSP;
1316 PUSHMARK(SP);
1317 XPUSHs(sv);
1318 PUTBACK;
1319 (void)call_pv("$module\::_get_$name", G_DISCARD);
1320 return (I32)0;
1321}
1322
1323I32
1324_set_$name(IV index, SV *sv) {
1325 dSP;
1326 PUSHMARK(SP);
1327 XPUSHs(sv);
1328 PUTBACK;
1329 (void)call_pv("$module\::_set_$name", G_DISCARD);
1330 return (I32)0;
1331}
1332
1333END
1334}
1335
1336sub print_tievar_xsubs {
1337 my($fh, $name, $type) = @_;
1338 print $fh <<END;
1339void
1340_tievar_$name(sv)
1341 SV* sv
1342 PREINIT:
1343 struct ufuncs uf;
1344 CODE:
1345 uf.uf_val = &_get_$name;
1346 uf.uf_set = &_set_$name;
1347 uf.uf_index = (IV)&_get_$name;
1348 sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
1349
1350void
1351_get_$name(THIS)
1352 $type THIS = NO_INIT
1353 CODE:
1354 THIS = $name;
1355 OUTPUT:
1356 SETMAGIC: DISABLE
1357 THIS
1358
1359void
1360_set_$name(THIS)
1361 $type THIS
1362 CODE:
1363 $name = THIS;
1364
1365END
1366}
1367
7c1d48a5
GS
1368sub print_accessors {
1369 my($fh, $name, $struct) = @_;
1370 return unless defined $struct && $name !~ /\s|_ANON/;
1371 $name = normalize_type($name);
1372 my $ptrname = normalize_type("$name *");
32fb2b78
GS
1373 print $fh <<"EOF";
1374
1375MODULE = $module PACKAGE = ${name} $prefix
1376
1377$name *
1378_to_ptr(THIS)
1379 $name THIS = NO_INIT
1380 PROTOTYPE: \$
1381 CODE:
1382 if (sv_derived_from(ST(0), "$name")) {
1383 STRLEN len;
1384 char *s = SvPV((SV*)SvRV(ST(0)), len);
1385 if (len != sizeof(THIS))
1386 croak("Size \%d of packed data != expected \%d",
1387 len, sizeof(THIS));
1388 RETVAL = ($name *)s;
1389 }
1390 else
1391 croak("THIS is not of type $name");
1392 OUTPUT:
1393 RETVAL
1394
1395$name
1396new(CLASS)
1397 char *CLASS = NO_INIT
1398 PROTOTYPE: \$
1399 CODE:
1400 Zero((void*)&RETVAL, sizeof(RETVAL), char);
1401 OUTPUT:
1402 RETVAL
7c1d48a5
GS
1403
1404MODULE = $module PACKAGE = ${name}Ptr $prefix
1405
1406EOF
1407 my @items = @$struct;
1408 while (@items) {
1409 my $item = shift @items;
1410 if ($item->[0] =~ /_ANON/) {
32fb2b78 1411 if (defined $item->[2]) {
7c1d48a5 1412 push @items, map [
32fb2b78 1413 @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
7c1d48a5
GS
1414 ], @{ $structs{$item->[0]} };
1415 } else {
1416 push @items, @{ $structs{$item->[0]} };
1417 }
1418 } else {
1419 my $type = normalize_type($item->[0]);
32fb2b78 1420 my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
7c1d48a5 1421 print $fh <<"EOF";
32fb2b78
GS
1422$ttype
1423$item->[2](THIS, __value = NO_INIT)
7c1d48a5
GS
1424 $ptrname THIS
1425 $type __value
1426 PROTOTYPE: \$;\$
1427 CODE:
7c1d48a5
GS
1428 if (items > 1)
1429 THIS->$item->[-1] = __value;
32fb2b78
GS
1430 RETVAL = @{[
1431 $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
1432 ]};
7c1d48a5
GS
1433 OUTPUT:
1434 RETVAL
1435
1436EOF
1437 }
1438 }
1439}
1440
b7d5fa84
IZ
1441sub accessor_docs {
1442 my($name, $struct) = @_;
1443 return unless defined $struct && $name !~ /\s|_ANON/;
1444 $name = normalize_type($name);
1445 my $ptrname = $name . 'Ptr';
1446 my @items = @$struct;
1447 my @list;
1448 while (@items) {
1449 my $item = shift @items;
1450 if ($item->[0] =~ /_ANON/) {
1451 if (defined $item->[2]) {
1452 push @items, map [
1453 @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
1454 ], @{ $structs{$item->[0]} };
1455 } else {
1456 push @items, @{ $structs{$item->[0]} };
1457 }
1458 } else {
1459 push @list, $item->[2];
1460 }
1461 }
b68ece06 1462 my $methods = (join '(...)>, C<', @list) . '(...)';
b7d5fa84 1463
b68ece06
IZ
1464 my $pod = <<"EOF";
1465#
1466#=head2 Object and class methods for C<$name>/C<$ptrname>
1467#
1468#The principal Perl representation of a C object of type C<$name> is an
1469#object of class C<$ptrname> which is a reference to an integer
1470#representation of a C pointer. To create such an object, one may use
1471#a combination
1472#
1473# my \$buffer = $name->new();
1474# my \$obj = \$buffer->_to_ptr();
1475#
1476#This exersizes the following two methods, and an additional class
1477#C<$name>, the internal representation of which is a reference to a
1478#packed string with the C structure. Keep in mind that \$buffer should
1479#better survive longer than \$obj.
1480#
1481#=over
1482#
1483#=item C<\$object_of_type_$name-E<gt>_to_ptr()>
1484#
1485#Converts an object of type C<$name> to an object of type C<$ptrname>.
1486#
1487#=item C<$name-E<gt>new()>
1488#
1489#Creates an empty object of type C<$name>. The corresponding packed
1490#string is zeroed out.
1491#
1492#=item C<$methods>
1493#
1494#return the current value of the corresponding element if called
1495#without additional arguments. Set the element to the supplied value
1496#(and return the new value) if called with an additional argument.
1497#
1498#Applicable to objects of type C<$ptrname>.
1499#
1500#=back
1501#
b7d5fa84 1502EOF
b68ece06
IZ
1503 $pod =~ s/^\#//gm;
1504 return $pod;
b7d5fa84
IZ
1505}
1506
5273d82d
IZ
1507# Should be called before any actual call to normalize_type().
1508sub get_typemap {
1509 # We do not want to read ./typemap by obvios reasons.
1510 my @tm = qw(../../../typemap ../../typemap ../typemap);
1511 my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap";
1512 unshift @tm, $stdtypemap;
1513 my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
ddf6bed1
IZ
1514
1515 # Start with useful default values
9cacc32e 1516 $typemap{float} = 'T_NV';
ddf6bed1 1517
3cb4da91 1518 foreach my $typemap (@tm) {
5273d82d
IZ
1519 next unless -e $typemap ;
1520 # skip directories, binary files etc.
1521 warn " Scanning $typemap\n";
1522 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1523 unless -T $typemap ;
1524 open(TYPEMAP, $typemap)
1525 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1526 my $mode = 'Typemap';
1527 while (<TYPEMAP>) {
1528 next if /^\s*\#/;
1529 if (/^INPUT\s*$/) { $mode = 'Input'; next; }
1530 elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; }
1531 elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1532 elsif ($mode eq 'Typemap') {
1533 next if /^\s*($|\#)/ ;
3cb4da91 1534 my ($type, $image);
ddf6bed1 1535 if ( ($type, $image) =
5273d82d
IZ
1536 /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1537 # This may reference undefined functions:
1538 and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
ddf6bed1 1539 $typemap{normalize_type($type)} = $image;
5273d82d
IZ
1540 }
1541 }
1542 }
1543 close(TYPEMAP) or die "Cannot close $typemap: $!";
1544 }
1545 %std_types = %types_seen;
1546 %types_seen = ();
1547}
1548
ead2a595 1549
ddf6bed1 1550sub normalize_type { # Second arg: do not strip const's before \*
ead2a595 1551 my $type = shift;
3cb4da91
IZ
1552 my $do_keep_deep_const = shift;
1553 # If $do_keep_deep_const this is heuristical only
1554 my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
ddf6bed1 1555 my $ignore_mods
3cb4da91
IZ
1556 = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1557 if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately!
1558 $type =~ s/$ignore_mods//go;
7aff18a2
GS
1559 }
1560 else {
3cb4da91
IZ
1561 $type =~ s/$ignore_mods//go;
1562 }
f1f595f5 1563 $type =~ s/([^\s\w])/ $1 /g;
ead2a595
PP
1564 $type =~ s/\s+$//;
1565 $type =~ s/^\s+//;
ddf6bed1
IZ
1566 $type =~ s/\s+/ /g;
1567 $type =~ s/\* (?=\*)/*/g;
1568 $type =~ s/\. \. \./.../g;
1569 $type =~ s/ ,/,/g;
5273d82d
IZ
1570 $types_seen{$type}++
1571 unless $type eq '...' or $type eq 'void' or $std_types{$type};
ead2a595
PP
1572 $type;
1573}
1574
ddf6bed1
IZ
1575my $need_opaque;
1576
1577sub assign_typemap_entry {
1578 my $type = shift;
1579 my $otype = $type;
1580 my $entry;
1581 if ($tmask and $type =~ /$tmask/) {
1582 print "Type $type matches -o mask\n" if $opt_d;
1583 $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1584 }
1585 elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1586 $type = normalize_type $type;
1587 print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1588 $entry = assign_typemap_entry($type);
1589 }
40292913
IZ
1590 # XXX good do better if our UV happens to be long long
1591 return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/;
ddf6bed1
IZ
1592 $entry ||= $typemap{$otype}
1593 || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1594 $typemap{$otype} = $entry;
1595 $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1596 return $entry;
1597}
1598
32fb2b78
GS
1599for (@vdecls) {
1600 print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
1601}
1602
ead2a595 1603if ($opt_x) {
32fb2b78
GS
1604 for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
1605 if ($opt_a) {
1606 while (my($name, $struct) = each %structs) {
1607 print_accessors(\*XS, $name, $struct);
7c1d48a5 1608 }
32fb2b78 1609 }
ead2a595
PP
1610}
1611
a0d0e21e 1612close XS;
5273d82d
IZ
1613
1614if (%types_seen) {
1615 my $type;
1616 warn "Writing $ext$modpname/typemap\n";
1617 open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1618
3cb4da91 1619 for $type (sort keys %types_seen) {
ddf6bed1
IZ
1620 my $entry = assign_typemap_entry $type;
1621 print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
5273d82d
IZ
1622 }
1623
ddf6bed1
IZ
1624 print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1625#############################################################################
1626INPUT
1627T_OPAQUE_STRUCT
1628 if (sv_derived_from($arg, \"${ntype}\")) {
1629 STRLEN len;
1630 char *s = SvPV((SV*)SvRV($arg), len);
1631
1632 if (len != sizeof($var))
1633 croak(\"Size %d of packed data != expected %d\",
1634 len, sizeof($var));
1635 $var = *($type *)s;
1636 }
1637 else
1638 croak(\"$var is not of type ${ntype}\")
1639#############################################################################
1640OUTPUT
1641T_OPAQUE_STRUCT
1642 sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1643EOP
1644
5273d82d
IZ
1645 close TM or die "Cannot close typemap file for write: $!";
1646}
1647
2920c5d2 1648} # if( ! $opt_X )
e1666bf5 1649
8e07c86e
AD
1650warn "Writing $ext$modpname/Makefile.PL\n";
1651open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
a0d0e21e 1652
11946041
JS
1653my $prereq_pm;
1654
1655if ( $compat_version < 5.00702 and $new_test )
1656{
1657 $prereq_pm = q%'Test::More' => 0%;
1658}
1659else
1660{
1661 $prereq_pm = '';
1662}
1663
8bc03d0d 1664print PL <<END;
a0d0e21e
LW
1665use ExtUtils::MakeMaker;
1666# See lib/ExtUtils/MakeMaker.pm for details of how to influence
42793c05 1667# the contents of the Makefile that is written.
8bc03d0d
GS
1668WriteMakefile(
1669 'NAME' => '$module',
1670 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION
11946041 1671 'PREREQ_PM' => {$prereq_pm}, # e.g., Module::Name => 1.1
fcd67389
TJ
1672 (\$] >= 5.005 ? ## Add these new keywords supported since 5.005
1673 (ABSTRACT_FROM => '$modfname.pm', # retrieve abstract from module
1674 AUTHOR => '$author <$email>') : ()),
a0d0e21e 1675END
8bc03d0d 1676if (!$opt_X) { # print C stuff, unless XS is disabled
ddf6bed1 1677 $opt_F = '' unless defined $opt_F;
b68ece06
IZ
1678 my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
1679 my $Ihelp = ($I ? '-I. ' : '');
1680 my $Icomment = ($I ? '' : <<EOC);
1681 # Insert -I. if you add *.h files later:
1682EOC
1683
8bc03d0d
GS
1684 print PL <<END;
1685 'LIBS' => ['$extralibs'], # e.g., '-lm'
1686 'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING'
f1f595f5 1687$Icomment 'INC' => '$I', # e.g., '${Ihelp}-I/usr/include/other'
b68ece06
IZ
1688END
1689
1690 my $C = grep $_ ne "$modfname.c", (glob '*.c'), (glob '*.cc'), (glob '*.C');
1691 my $Cpre = ($C ? '' : '# ');
1692 my $Ccomment = ($C ? '' : <<EOC);
1693 # Un-comment this if you add C files to link with later:
1694EOC
1695
1696 print PL <<END;
1697$Ccomment $Cpre\'OBJECT' => '\$(O_FILES)', # link all the C files too
8bc03d0d 1698END
2920c5d2 1699}
a0d0e21e 1700print PL ");\n";
f508c652
PP
1701close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
1702
fcd67389
TJ
1703# Create a simple README since this is a CPAN requirement
1704# and it doesnt hurt to have one
1705warn "Writing $ext$modpname/README\n";
1706open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
1707my $thisyear = (gmtime)[5] + 1900;
1708my $rmhead = "$modpname version $TEMPLATE_VERSION";
1709my $rmheadeq = "=" x length($rmhead);
11946041
JS
1710
1711my $rm_prereq;
1712
1713if ( $compat_version < 5.00702 and $new_test )
1714{
1715 $rm_prereq = 'Test::More';
1716}
1717else
1718{
1719 $rm_prereq = 'blah blah blah';
1720}
1721
fcd67389
TJ
1722print RM <<_RMEND_;
1723$rmhead
1724$rmheadeq
1725
1726The README is used to introduce the module and provide instructions on
1727how to install the module, any machine dependencies it may have (for
1728example C compilers and installed libraries) and any other information
1729that should be provided before the module is installed.
1730
1731A README file is required for CPAN modules since CPAN extracts the
1732README file from a module distribution so that people browsing the
1733archive can use it get an idea of the modules uses. It is usually a
1734good idea to provide version information here so that people can
1735decide whether fixes for the module are worth downloading.
1736
1737INSTALLATION
1738
1739To install this module type the following:
1740
1741 perl Makefile.PL
1742 make
1743 make test
1744 make install
1745
1746DEPENDENCIES
1747
1748This module requires these other modules and libraries:
1749
11946041 1750 $rm_prereq
fcd67389
TJ
1751
1752COPYRIGHT AND LICENCE
1753
1754Put the correct copyright and licence information here.
1755
ff1a6a48
JH
1756Copyright (C) $thisyear $author
1757
1758This library is free software; you can redistribute it and/or modify
1759it under the same terms as Perl itself.
fcd67389
TJ
1760
1761_RMEND_
1762close(RM) || die "Can't close $ext$modpname/README: $!\n";
1763
1b99c731
MS
1764my $testdir = "t";
1765my $testfile = "$testdir/1.t";
e42bd63e
JH
1766unless (-d "$testdir") {
1767 mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n";
1768}
1b99c731 1769warn "Writing $ext$modpname/$testfile\n";
d3837a33
NC
1770my $tests = @const_names ? 2 : 1;
1771
1b99c731 1772open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n";
11946041 1773
d3837a33 1774print EX <<_END_;
f508c652 1775# Before `make install' is performed this script should be runnable with
1b99c731 1776# `make test'. After `make install' it should work as `perl 1.t'
f508c652 1777
452e8205 1778#########################
f508c652 1779
d3837a33 1780# change 'tests => $tests' to 'tests => last_test_to_print';
f508c652 1781
11946041
JS
1782_END_
1783
1784my $test_mod = 'Test::More';
1785
1786if ( $old_test or ($compat_version < 5.007 and not $new_test ))
1787{
1788 my $test_mod = 'Test';
1789
1790 print EX <<_END_;
452e8205 1791use Test;
d3837a33 1792BEGIN { plan tests => $tests };
f508c652 1793use $module;
452e8205 1794ok(1); # If we made it this far, we're ok.
f508c652 1795
d3837a33 1796_END_
11946041
JS
1797
1798 if (@const_names) {
1799 my $const_names = join " ", @const_names;
1800 print EX <<'_END_';
d3837a33 1801
af6c647e
NC
1802my $fail;
1803foreach my $constname (qw(
1804_END_
11946041
JS
1805
1806 print EX wrap ("\t", "\t", $const_names);
1807 print EX (")) {\n");
1808
1809 print EX <<_END_;
d3837a33
NC
1810 next if (eval "my \\\$a = \$constname; 1");
1811 if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
1812 print "# pass: \$\@";
1813 } else {
1814 print "# fail: \$\@";
1815 \$fail = 1;
1816 }
1817}
1818if (\$fail) {
1819 print "not ok 2\\n";
1820} else {
1821 print "ok 2\\n";
1822}
1823
1824_END_
11946041
JS
1825 }
1826}
1827else
1828{
1829 print EX <<_END_;
1830use Test::More tests => $tests;
1831BEGIN { use_ok('$module') };
1832
1833_END_
1834
1835 if (@const_names) {
1836 my $const_names = join " ", @const_names;
1837 print EX <<'_END_';
1838
1839my $fail = 0;
1840foreach my $constname (qw(
1841_END_
1842
1843 print EX wrap ("\t", "\t", $const_names);
1844 print EX (")) {\n");
1845
1846 print EX <<_END_;
1847 next if (eval "my \\\$a = \$constname; 1");
1848 if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
1849 print "# pass: \$\@";
1850 } else {
1851 print "# fail: \$\@";
1852 \$fail = 1;
1853 }
1854
1855}
1856
1857ok( \$fail == 0 , 'Constants' );
1858_END_
1859 }
d3837a33 1860}
11946041
JS
1861
1862print EX <<_END_;
452e8205 1863#########################
f508c652 1864
11946041
JS
1865# Insert your test code below, the $test_mod module is use()ed here so read
1866# its man page ( perldoc $test_mod ) for help writing this test script.
e1666bf5 1867
f508c652 1868_END_
11946041 1869
1b99c731 1870close(EX) || die "Can't close $ext$modpname/$testfile: $!\n";
a0d0e21e 1871
c0f8b9cd 1872unless ($opt_C) {
ddf6bed1
IZ
1873 warn "Writing $ext$modpname/Changes\n";
1874 $" = ' ';
1875 open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
1876 @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
1877 print EX <<EOP;
1878Revision history for Perl extension $module.
1879
1880$TEMPLATE_VERSION @{[scalar localtime]}
1881\t- original version; created by h2xs $H2XS_VERSION with options
1882\t\t@ARGS
1883
1884EOP
1885 close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
c0f8b9cd 1886}
c07a80fd
PP
1887
1888warn "Writing $ext$modpname/MANIFEST\n";
5ae7f1db 1889open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
1b99c731 1890my @files = grep { -f } (<*>, <t/*>);
5ae7f1db
PP
1891if (!@files) {
1892 eval {opendir(D,'.');};
1893 unless ($@) { @files = readdir(D); closedir(D); }
1894}
1895if (!@files) { @files = map {chomp && $_} `ls`; }
55497cff
PP
1896if ($^O eq 'VMS') {
1897 foreach (@files) {
1898 # Clip trailing '.' for portability -- non-VMS OSs don't expect it
1899 s%\.$%%;
1900 # Fix up for case-sensitive file systems
1901 s/$modfname/$modfname/i && next;
1902 $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
bbce6d69 1903 $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
55497cff
PP
1904 }
1905}
3e3baf6d 1906print MANI join("\n",@files), "\n";
5ae7f1db 1907close MANI;
40000a8c 1908!NO!SUBS!
4633a7c4
LW
1909
1910close OUT or die "Can't close $file: $!";
1911chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1912exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1 1913chdir $origdir;