This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
remove outdated notes in makefiles
[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.
8a5546a1 16$origdir = cwd;
44a8e56a 17chdir dirname($0);
18$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!";
5f05dabc 29$Config{startperl}
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
3edbfbe5
TB
38=head1 NAME
39
40h2xs - convert .h C header files to Perl extensions
41
42=head1 SYNOPSIS
43
c0f8b9cd 44B<h2xs> [B<-ACOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]]
f508c652 45
46B<h2xs> B<-h>
3edbfbe5
TB
47
48=head1 DESCRIPTION
49
a887ff11
BS
50I<h2xs> builds a Perl extension from C header files. The extension
51will include functions which can be used to retrieve the value of any
52#define statement which was in the C header files.
3edbfbe5
TB
53
54The I<module_name> will be used for the name of the extension. If
a887ff11
BS
55module_name is not supplied then the name of the first header file
56will be used, with the first character capitalized.
3edbfbe5
TB
57
58If the extension might need extra libraries, they should be included
59here. The extension Makefile.PL will take care of checking whether
60the libraries actually exist and how they should be loaded.
61The extra libraries should be specified in the form -lm -lposix, etc,
62just as on the cc command line. By default, the Makefile.PL will
63search through the library path determined by Configure. That path
64can be augmented by including arguments of the form B<-L/another/library/path>
65in the extra-libraries argument.
66
67=head1 OPTIONS
68
69=over 5
70
f508c652 71=item B<-A>
3edbfbe5 72
f508c652 73Omit all autoload facilities. This is the same as B<-c> but also removes the
9ef261b5 74S<C<use AutoLoader>> statement from the .pm file.
3edbfbe5 75
c0f8b9cd
GS
76=item B<-C>
77
78Omits creation of the F<Changes> file, and adds a HISTORY section to
79the POD template.
80
b73edd97 81=item B<-F>
82
83Additional flags to specify to C preprocessor when scanning header for
ddf6bed1
IZ
84function declarations. Should not be used without B<-x>.
85
86=item B<-M> I<regular expression>
87
88selects functions/macros to process.
b73edd97 89
2920c5d2 90=item B<-O>
91
92Allows a pre-existing extension directory to be overwritten.
93
f508c652 94=item B<-P>
3edbfbe5 95
f508c652 96Omit the autogenerated stub POD section.
3edbfbe5 97
b73edd97 98=item B<-X>
99
100Omit the XS portion. Used to generate templates for a module which is not
9ef261b5 101XS-based. C<-c> and C<-f> are implicitly enabled.
b73edd97 102
7c1d48a5
GS
103=item B<-a>
104
105Generate an accessor method for each element of structs and unions. The
106generated methods are named after the element name; will return the current
107value of the element if called without additional arguments; and will set
108the element to the supplied value (and return the old value) if called with
109an additional argument.
110
3edbfbe5
TB
111=item B<-c>
112
113Omit C<constant()> from the .xs file and corresponding specialised
114C<AUTOLOAD> from the .pm file.
115
b73edd97 116=item B<-d>
117
118Turn on debugging messages.
119
f508c652 120=item B<-f>
3edbfbe5 121
f508c652 122Allows an extension to be created for a header even if that header is
ddf6bed1 123not found in standard include directories.
f508c652 124
125=item B<-h>
126
127Print the usage, help and version for this h2xs and exit.
128
129=item B<-n> I<module_name>
130
131Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
132
ddf6bed1
IZ
133=item B<-o> I<regular expression>
134
135Use "opaque" data type for the C types matched by the regular
136expression, even if these types are C<typedef>-equivalent to types
137from typemaps. Should not be used without B<-x>.
138
139This may be useful since, say, types which are C<typedef>-equivalent
140to integers may represent OS-related handles, and one may want to work
141with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
142Use C<-o .> if you want to handle all the C<typedef>ed types as opaque types.
143
144The type-to-match is whitewashed (except for commas, which have no
145whitespace before them, and multiple C<*> which have no whitespace
146between them).
147
ead2a595 148=item B<-p> I<prefix>
149
150Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_>
151This sets up the XS B<PREFIX> keyword and removes the prefix from functions that are
98a6f11e 152autoloaded via the C<constant()> mechanism.
ead2a595 153
154=item B<-s> I<sub1,sub2>
155
156Create a perl subroutine for the specified macros rather than autoload with the constant() subroutine.
157These macros are assumed to have a return type of B<char *>, e.g., S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
158
f508c652 159=item B<-v> I<version>
160
161Specify a version number for this extension. This version number is added
162to the templates. The default is 0.01.
3edbfbe5 163
760ac839
LW
164=item B<-x>
165
166Automatically generate XSUBs basing on function declarations in the
167header file. The package C<C::Scan> should be installed. If this
168option is specified, the name of the header file may look like
169C<NAME1,NAME2>. In this case NAME1 is used instead of the specified string,
b73edd97 170but XSUBs are emitted only for the declarations included from file NAME2.
760ac839 171
5273d82d
IZ
172Note that some types of arguments/return-values for functions may
173result in XSUB-declarations/typemap-entries which need
174hand-editing. Such may be objects which cannot be converted from/to a
ddf6bed1
IZ
175pointer (like C<long long>), pointers to functions, or arrays. See
176also the section on L<LIMITATIONS of B<-x>>.
5273d82d 177
3edbfbe5
TB
178=back
179
180=head1 EXAMPLES
181
182
183 # Default behavior, extension is Rusers
184 h2xs rpcsvc/rusers
185
186 # Same, but extension is RUSERS
187 h2xs -n RUSERS rpcsvc/rusers
188
189 # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
190 h2xs rpcsvc::rusers
191
192 # Extension is ONC::RPC. Still finds <rpcsvc/rusers.h>
193 h2xs -n ONC::RPC rpcsvc/rusers
194
195 # Without constant() or AUTOLOAD
196 h2xs -c rpcsvc/rusers
197
198 # Creates templates for an extension named RPC
199 h2xs -cfn RPC
200
201 # Extension is ONC::RPC.
202 h2xs -cfn ONC::RPC
203
204 # Makefile.PL will look for library -lrpc in
205 # additional directory /opt/net/lib
206 h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
207
ead2a595 208 # Extension is DCE::rgynbase
209 # prefix "sec_rgy_" is dropped from perl function names
210 h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
211
212 # Extension is DCE::rgynbase
213 # prefix "sec_rgy_" is dropped from perl function names
214 # subroutines are created for sec_rgy_wildcard_name and sec_rgy_wildcard_sid
215 h2xs -n DCE::rgynbase -p sec_rgy_ \
216 -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
3edbfbe5 217
5273d82d 218 # Make XS without defines in perl.h, but with function declarations
760ac839
LW
219 # visible from perl.h. Name of the extension is perl1.
220 # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
221 # Extra backslashes below because the string is passed to shell.
5273d82d
IZ
222 # Note that a directory with perl header files would
223 # be added automatically to include path.
224 h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
760ac839
LW
225
226 # Same with function declaration in proto.h as visible from perl.h.
5273d82d 227 h2xs -xAn perl2 perl.h,proto.h
760ac839 228
ddf6bed1
IZ
229 # Same but select only functions which match /^av_/
230 h2xs -M '^av_' -xAn perl2 perl.h,proto.h
231
232 # Same but treat SV* etc as "opaque" types
233 h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h
234
3edbfbe5
TB
235=head1 ENVIRONMENT
236
237No environment variables are used.
238
239=head1 AUTHOR
240
241Larry Wall and others
242
243=head1 SEE ALSO
244
f508c652 245L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
3edbfbe5
TB
246
247=head1 DIAGNOSTICS
248
760ac839 249The usual warnings if it cannot read or write the files involved.
3edbfbe5 250
ddf6bed1
IZ
251=head1 LIMITATIONS of B<-x>
252
253F<h2xs> would not distinguish whether an argument to a C function
254which is of the form, say, C<int *>, is an input, output, or
255input/output parameter. In particular, argument declarations of the
256form
257
258 int
259 foo(n)
260 int *n
261
262should be better rewritten as
263
264 int
265 foo(n)
266 int &n
267
268if C<n> is an input parameter.
269
270Additionally, F<h2xs> has no facilities to intuit that a function
271
272 int
273 foo(addr,l)
274 char *addr
275 int l
276
277takes a pair of address and length of data at this address, so it is better
278to rewrite this function as
279
280 int
281 foo(sv)
7aff18a2
GS
282 SV *addr
283 PREINIT:
284 STRLEN len;
285 char *s;
286 CODE:
287 s = SvPV(sv,len);
288 RETVAL = foo(s, len);
289 OUTPUT:
290 RETVAL
ddf6bed1
IZ
291
292or alternately
293
294 static int
295 my_foo(SV *sv)
296 {
297 STRLEN len;
298 char *s = SvPV(sv,len);
299
300 return foo(s, len);
301 }
302
303 MODULE = foo PACKAGE = foo PREFIX = my_
304
305 int
306 foo(sv)
307 SV *sv
308
309See L<perlxs> and L<perlxstut> for additional details.
310
3edbfbe5
TB
311=cut
312
3cb4da91
IZ
313use strict;
314
315
ddf6bed1 316my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/;
f508c652 317my $TEMPLATE_VERSION = '0.01';
ddf6bed1 318my @ARGS = @ARGV;
a0d0e21e
LW
319
320use Getopt::Std;
321
e1666bf5
TB
322sub usage{
323 warn "@_\n" if @_;
c0f8b9cd 324 die "h2xs [-ACOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]]
f508c652 325version: $H2XS_VERSION
3edbfbe5 326 -A Omit all autoloading facilities (implies -c).
c0f8b9cd 327 -C Omit creating the Changes file, add HISTORY heading to stub POD.
b73edd97 328 -F Additional flags for C preprocessor (used with -x).
ddf6bed1 329 -M Mask to select C functions/macros (default is select all).
2920c5d2 330 -O Allow overwriting of a pre-existing extension directory.
f508c652 331 -P Omit the stub POD section.
9ef261b5 332 -X Omit the XS portion (implies both -c and -f).
7c1d48a5 333 -a Generate get/set accessors for struct and union members (used with -x).
b73edd97 334 -c Omit the constant() function and specialised AUTOLOAD from the XS file.
335 -d Turn on debugging messages.
336 -f Force creation of the extension even if the C header does not exist.
337 -h Display this help message
338 -n Specify a name to use for the extension (recommended).
ddf6bed1 339 -o Regular expression for \"opaque\" types.
b73edd97 340 -p Specify a prefix which should be removed from the Perl function names.
341 -s Create subroutines for specified macros.
f508c652 342 -v Specify a version number for this extension.
760ac839 343 -x Autogenerate XSUBs using C::Scan.
e1666bf5
TB
344extra_libraries
345 are any libraries that might be needed for loading the
346 extension, e.g. -lm would try to link in the math library.
f508c652 347";
e1666bf5 348}
a0d0e21e 349
a0d0e21e 350
7c1d48a5
GS
351getopts("ACF:M:OPXacdfhn:o:p:s:v:x") || usage;
352use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c
3cb4da91 353 $opt_d $opt_f $opt_h $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x);
a0d0e21e 354
e1666bf5 355usage if $opt_h;
f508c652 356
357if( $opt_v ){
358 $TEMPLATE_VERSION = $opt_v;
359}
9ef261b5
MS
360
361# -A implies -c.
e1666bf5 362$opt_c = 1 if $opt_A;
9ef261b5
MS
363
364# -X implies -c and -f
365$opt_c = $opt_f = 1 if $opt_X;
366
3cb4da91
IZ
367my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
368my $extralibs;
369my @path_h;
a0d0e21e 370
a887ff11
BS
371while (my $arg = shift) {
372 if ($arg =~ /^-l/i) {
373 $extralibs = "$arg @ARGV";
374 last;
375 }
376 push(@path_h, $arg);
377}
e1666bf5
TB
378
379usage "Must supply header file or module name\n"
a887ff11 380 unless (@path_h or $opt_n);
e1666bf5 381
ddf6bed1 382my $fmask;
3cb4da91 383my $tmask;
ddf6bed1
IZ
384
385$fmask = qr{$opt_M} if defined $opt_M;
386$tmask = qr{$opt_o} if defined $opt_o;
387my $tmask_all = $tmask && $opt_o eq '.';
388
389if ($opt_x) {
390 eval {require C::Scan; 1}
391 or die <<EOD;
392C::Scan required if you use -x option.
393To install C::Scan, execute
394 perl -MCPAN -e "install C::Scan"
395EOD
396 unless ($tmask_all) {
397 $C::Scan::VERSION >= 0.70
398 or die <<EOD;
399C::Scan v. 0.70 or later required unless you use -o . option.
400You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
401To install C::Scan, execute
402 perl -MCPAN -e "install C::Scan"
403EOD
404 }
7aff18a2
GS
405}
406elsif ($opt_o or $opt_F) {
ddf6bed1
IZ
407 warn <<EOD;
408Options -o and -F do not make sense without -x.
409EOD
410}
411
3cb4da91
IZ
412my @path_h_ini = @path_h;
413my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
a0d0e21e 414
a887ff11 415if( @path_h ){
ddf6bed1
IZ
416 use Config;
417 use File::Spec;
418 my @paths;
419 if ($^O eq 'VMS') { # Consider overrides of default location
3cb4da91
IZ
420 # XXXX This is not equivalent to what the older version did:
421 # it was looking at $hadsys header-file per header-file...
422 my($hadsys) = grep s!^sys/!!i , @path_h;
7aff18a2 423 @paths = qw( Sys$Library VAXC$Include );
ddf6bed1
IZ
424 push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
425 push @paths, qw( DECC$Library_Include DECC$System_Include );
7aff18a2
GS
426 }
427 else {
ddf6bed1
IZ
428 @paths = (File::Spec->curdir(), $Config{usrinc},
429 (split ' ', $Config{locincpth}), '/usr/include');
430 }
a887ff11
BS
431 foreach my $path_h (@path_h) {
432 $name ||= $path_h;
e1666bf5
TB
433 if( $path_h =~ s#::#/#g && $opt_n ){
434 warn "Nesting of headerfile ignored with -n\n";
435 }
436 $path_h .= ".h" unless $path_h =~ /\.h$/;
3cb4da91 437 my $fullpath = $path_h;
760ac839 438 $path_h =~ s/,.*$// if $opt_x;
3cb4da91 439 $fullpath{$path_h} = $fullpath;
ddf6bed1
IZ
440
441 if (not -f $path_h) {
442 my $tmp_path_h = $path_h;
443 for my $dir (@paths) {
444 last if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
445 }
ead2a595 446 }
5273d82d
IZ
447
448 if (!$opt_c) {
449 die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h );
450 # Scan the header file (we should deal with nested header files)
451 # Record the names of simple #define constants into const_names
a887ff11 452 # Function prototypes are processed below.
5273d82d 453 open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
ddf6bed1 454 defines:
5273d82d 455 while (<CH>) {
3cb4da91 456 if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) {
ddf6bed1
IZ
457 my $def = $1;
458 my $rest = $2;
459 $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
460 $rest =~ s/^\s+//;
461 $rest =~ s/\s+$//;
462 # Cannot do: (-1) and ((LHANDLE)3) are OK:
463 #print("Skip non-wordy $def => $rest\n"),
464 # next defines if $rest =~ /[^\w\$]/;
465 if ($rest =~ /"/) {
466 print("Skip stringy $def => $rest\n") if $opt_d;
467 next defines;
468 }
469 print "Matched $_ ($def)\n" if $opt_d;
470 $seen_define{$def} = $rest;
471 $_ = $def;
e1666bf5 472 next if /^_.*_h_*$/i; # special case, but for what?
760ac839 473 if (defined $opt_p) {
5273d82d
IZ
474 if (!/^$opt_p(\d)/) {
475 ++$prefix{$_} if s/^$opt_p//;
476 }
477 else {
478 warn "can't remove $opt_p prefix from '$_'!\n";
479 }
ead2a595 480 }
ddf6bed1
IZ
481 $prefixless{$def} = $_;
482 if (!$fmask or /$fmask/) {
483 print "... Passes mask of -M.\n" if $opt_d and $fmask;
484 $const_names{$_}++;
485 }
5273d82d
IZ
486 }
487 }
488 close(CH);
e1666bf5 489 }
a887ff11 490 }
a0d0e21e
LW
491}
492
e1666bf5 493
3cb4da91 494my $module = $opt_n || do {
a0d0e21e
LW
495 $name =~ s/\.h$//;
496 if( $name !~ /::/ ){
497 $name =~ s#^.*/##;
498 $name = "\u$name";
499 }
500 $name;
501};
502
3cb4da91 503my ($ext, $nested, @modparts, $modfname, $modpname);
8e07c86e 504(chdir 'ext', $ext = 'ext/') if -d 'ext';
a0d0e21e
LW
505
506if( $module =~ /::/ ){
507 $nested = 1;
508 @modparts = split(/::/,$module);
509 $modfname = $modparts[-1];
510 $modpname = join('/',@modparts);
511}
512else {
513 $nested = 0;
514 @modparts = ();
515 $modfname = $modpname = $module;
516}
517
518
2920c5d2 519if ($opt_O) {
520 warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
7aff18a2
GS
521}
522else {
2920c5d2 523 die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
524}
c07a80fd 525if( $nested ){
3cb4da91 526 my $modpath = "";
c07a80fd 527 foreach (@modparts){
528 mkdir("$modpath$_", 0777);
529 $modpath .= "$_/";
530 }
531}
a0d0e21e 532mkdir($modpname, 0777);
8e07c86e 533chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
a0d0e21e 534
5273d82d
IZ
535my %types_seen;
536my %std_types;
f4d63e4e
IZ
537my $fdecls = [];
538my $fdecls_parsed = [];
ddf6bed1
IZ
539my $typedef_rex;
540my %typedefs_pre;
541my %known_fnames;
7c1d48a5 542my %structs;
5273d82d 543
3cb4da91
IZ
544my @fnames;
545my @fnames_no_prefix;
5273d82d 546
2920c5d2 547if( ! $opt_X ){ # use XS, unless it was disabled
548 open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
5273d82d 549 if ($opt_x) {
5273d82d
IZ
550 require Config; # Run-time directive
551 warn "Scanning typemaps...\n";
552 get_typemap();
3cb4da91
IZ
553 my @td;
554 my @good_td;
555 my $addflags = $opt_F || '';
556
f4d63e4e 557 foreach my $filename (@path_h) {
3cb4da91
IZ
558 my $c;
559 my $filter;
560
561 if ($fullpath{$filename} =~ /,/) {
f4d63e4e
IZ
562 $filename = $`;
563 $filter = $';
564 }
565 warn "Scanning $filename for functions...\n";
566 $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
7c1d48a5 567 'add_cppflags' => $addflags, 'c_styles' => [qw(C++ C9X)];
f4d63e4e 568 $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
ddf6bed1 569
f4d63e4e
IZ
570 push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
571 push(@$fdecls, @{$c->get('fdecls')});
3cb4da91
IZ
572
573 push @td, @{$c->get('typedefs_maybe')};
7c1d48a5
GS
574 if ($opt_a) {
575 my $structs = $c->get('typedef_structs');
576 @structs{keys %$structs} = values %$structs;
577 }
3cb4da91
IZ
578
579 unless ($tmask_all) {
580 warn "Scanning $filename for typedefs...\n";
581 my $td = $c->get('typedef_hash');
582 # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
583 my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
584 push @good_td, @f_good_td;
585 @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td};
586 }
587 }
588 { local $" = '|';
6542b28e 589 $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
5273d82d 590 }
ddf6bed1
IZ
591 %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
592 if ($fmask) {
593 my @good;
594 for my $i (0..$#$fdecls_parsed) {
595 next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
596 push @good, $i;
597 print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
598 if $opt_d;
599 }
600 $fdecls = [@$fdecls[@good]];
601 $fdecls_parsed = [@$fdecls_parsed[@good]];
602 }
3cb4da91
IZ
603 @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
604 # Sort declarations:
605 {
606 my %h = map( ($_->[1], $_), @$fdecls_parsed);
607 $fdecls_parsed = [ @h{@fnames} ];
ddf6bed1 608 }
3cb4da91
IZ
609 @fnames_no_prefix = @fnames;
610 @fnames_no_prefix
611 = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix;
ddf6bed1 612 # Remove macros which expand to typedefs
ddf6bed1
IZ
613 print "Typedefs are @td.\n" if $opt_d;
614 my %td = map {($_, $_)} @td;
615 # Add some other possible but meaningless values for macros
616 for my $k (qw(char double float int long short unsigned signed void)) {
617 $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
618 }
619 # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
620 my $n = 0;
621 my %bad_macs;
622 while (keys %td > $n) {
623 $n = keys %td;
624 my ($k, $v);
625 while (($k, $v) = each %seen_define) {
626 # print("found '$k'=>'$v'\n"),
627 $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
628 }
629 }
630 # Now %bad_macs contains names of bad macros
631 for my $k (keys %bad_macs) {
632 delete $const_names{$prefixless{$k}};
633 print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
5273d82d 634 }
5273d82d 635 }
2920c5d2 636}
3cb4da91 637my @const_names = sort keys %const_names;
5273d82d 638
8e07c86e 639open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
a0d0e21e 640
a0d0e21e 641$" = "\n\t";
8e07c86e 642warn "Writing $ext$modpname/$modfname.pm\n";
a0d0e21e 643
a0d0e21e
LW
644print PM <<"END";
645package $module;
646
51fac20b 647require 5.005_62;
2920c5d2 648use strict;
8cd79558 649use warnings;
2920c5d2 650END
651
aba05478 652unless( $opt_X || $opt_c || $opt_A ){
2920c5d2 653 # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
654 # will want Carp.
655 print PM <<'END';
656use Carp;
2920c5d2 657END
658}
659
660print PM <<'END';
661
a0d0e21e 662require Exporter;
2920c5d2 663END
664
665print PM <<"END" if ! $opt_X; # use DynaLoader, unless XS was disabled
a0d0e21e 666require DynaLoader;
3edbfbe5
TB
667END
668
e1666bf5 669
9ef261b5
MS
670# Are we using AutoLoader or not?
671unless ($opt_A) { # no autoloader whatsoever.
672 unless ($opt_c) { # we're doing the AUTOLOAD
673 print PM "use AutoLoader;\n";
2920c5d2 674 }
9ef261b5
MS
675 else {
676 print PM "use AutoLoader qw(AUTOLOAD);\n"
2920c5d2 677 }
3edbfbe5 678}
3edbfbe5 679
9ef261b5 680# Determine @ISA.
77ca0c92 681my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this.
9ef261b5
MS
682$myISA .= ' DynaLoader' unless $opt_X; # no XS
683$myISA .= ');';
684print PM "\n$myISA\n\n";
e1666bf5 685
3cb4da91
IZ
686my @exported_names = (@const_names, @fnames_no_prefix);
687
3edbfbe5 688print PM<<"END";
e1666bf5
TB
689# Items to export into callers namespace by default. Note: do not export
690# names by default without a very good reason. Use EXPORT_OK instead.
691# Do not simply export all your public functions/methods/constants.
ddf6bed1
IZ
692
693# This allows declaration use $module ':all';
694# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
695# will save memory.
51fac20b 696our %EXPORT_TAGS = ( 'all' => [ qw(
3cb4da91 697 @exported_names
ddf6bed1
IZ
698) ] );
699
51fac20b 700our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
ddf6bed1 701
77ca0c92 702our \@EXPORT = qw(
e1666bf5 703 @const_names
a0d0e21e 704);
77ca0c92 705our \$VERSION = '$TEMPLATE_VERSION';
f508c652 706
e1666bf5
TB
707END
708
2920c5d2 709print PM <<"END" unless $opt_c or $opt_X;
a0d0e21e 710sub AUTOLOAD {
3edbfbe5
TB
711 # This AUTOLOAD is used to 'autoload' constants from the constant()
712 # XS function. If a constant is not found then control is passed
713 # to the AUTOLOAD in AutoLoader.
e1666bf5 714
2920c5d2 715 my \$constname;
65346fe1 716 our \$AUTOLOAD;
a0d0e21e 717 (\$constname = \$AUTOLOAD) =~ s/.*:://;
1d3434b8 718 croak "&$module::constant not defined" if \$constname eq 'constant';
2920c5d2 719 my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
a0d0e21e 720 if (\$! != 0) {
265f5c4a 721 if (\$! =~ /Invalid/ || \$!{EINVAL}) {
a0d0e21e
LW
722 \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
723 goto &AutoLoader::AUTOLOAD;
724 }
725 else {
7aff18a2 726 croak "Your vendor has not defined $module macro \$constname";
a0d0e21e
LW
727 }
728 }
7aff18a2
GS
729 {
730 no strict 'refs';
731 # Fixed between 5.005_53 and 5.005_61
732 if (\$] >= 5.00561) {
733 *\$AUTOLOAD = sub () { \$val };
734 }
735 else {
736 *\$AUTOLOAD = sub { \$val };
737 }
ddf6bed1 738 }
a0d0e21e
LW
739 goto &\$AUTOLOAD;
740}
741
a0d0e21e 742END
a0d0e21e 743
2920c5d2 744if( ! $opt_X ){ # print bootstrap, unless XS is disabled
745 print PM <<"END";
f508c652 746bootstrap $module \$VERSION;
2920c5d2 747END
748}
749
3cb4da91 750my $after;
2920c5d2 751if( $opt_P ){ # if POD is disabled
752 $after = '__END__';
753}
754else {
755 $after = '=cut';
756}
757
758print PM <<"END";
a0d0e21e 759
e1666bf5 760# Preloaded methods go here.
9ef261b5
MS
761END
762
763print PM <<"END" unless $opt_A;
a0d0e21e 764
2920c5d2 765# Autoload methods go after $after, and are processed by the autosplit program.
9ef261b5
MS
766END
767
768print PM <<"END";
a0d0e21e
LW
769
7701;
e1666bf5 771__END__
a0d0e21e 772END
a0d0e21e 773
3cb4da91
IZ
774my $author = "A. U. Thor";
775my $email = 'a.u.thor@a.galaxy.far.far.away';
f508c652 776
c0f8b9cd
GS
777my $revhist = '';
778$revhist = <<EOT if $opt_C;
779
780=head1 HISTORY
781
782=over 8
783
784=item $TEMPLATE_VERSION
785
ddf6bed1
IZ
786Original version; created by h2xs $H2XS_VERSION with options
787
788 @ARGS
c0f8b9cd
GS
789
790=back
791
792EOT
793
ddf6bed1
IZ
794my $exp_doc = <<EOD;
795
796=head2 EXPORT
797
798None by default.
799
800EOD
5273d82d 801if (@const_names and not $opt_P) {
ddf6bed1
IZ
802 $exp_doc .= <<EOD;
803=head2 Exportable constants
5273d82d
IZ
804
805 @{[join "\n ", @const_names]}
806
807EOD
808}
809if (defined $fdecls and @$fdecls and not $opt_P) {
ddf6bed1
IZ
810 $exp_doc .= <<EOD;
811=head2 Exportable functions
5273d82d 812
3cb4da91
IZ
813EOD
814 $exp_doc .= <<EOD if $opt_p;
815When accessing these functions from Perl, prefix C<$opt_p> should be removed.
816
817EOD
818 $exp_doc .= <<EOD;
ddf6bed1 819 @{[join "\n ", @known_fnames{@fnames}]}
5273d82d
IZ
820
821EOD
822}
823
3cb4da91 824my $pod = <<"END" unless $opt_P;
7aff18a2 825## Below is stub documentation for your module. You better edit it!
f508c652 826#
827#=head1 NAME
828#
829#$module - Perl extension for blah blah blah
830#
831#=head1 SYNOPSIS
832#
833# use $module;
834# blah blah blah
835#
836#=head1 DESCRIPTION
837#
7aff18a2 838#Stub documentation for $module, created by h2xs. It looks like the
f508c652 839#author of the extension was negligent enough to leave the stub
840#unedited.
841#
842#Blah blah blah.
ddf6bed1 843#$exp_doc$revhist
f508c652 844#=head1 AUTHOR
845#
846#$author, $email
847#
848#=head1 SEE ALSO
849#
850#perl(1).
851#
852#=cut
853END
854
855$pod =~ s/^\#//gm unless $opt_P;
856print PM $pod unless $opt_P;
857
a0d0e21e
LW
858close PM;
859
e1666bf5 860
2920c5d2 861if( ! $opt_X ){ # print XS, unless it is disabled
8e07c86e 862warn "Writing $ext$modpname/$modfname.xs\n";
e1666bf5 863
a0d0e21e
LW
864print XS <<"END";
865#include "EXTERN.h"
866#include "perl.h"
867#include "XSUB.h"
868
869END
a887ff11 870if( @path_h ){
3cb4da91 871 foreach my $path_h (@path_h_ini) {
a0d0e21e
LW
872 my($h) = $path_h;
873 $h =~ s#^/usr/include/##;
ead2a595 874 if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
a887ff11
BS
875 print XS qq{#include <$h>\n};
876 }
877 print XS "\n";
a0d0e21e
LW
878}
879
ddf6bed1
IZ
880my %pointer_typedefs;
881my %struct_typedefs;
882
883sub td_is_pointer {
884 my $type = shift;
885 my $out = $pointer_typedefs{$type};
886 return $out if defined $out;
887 my $otype = $type;
888 $out = ($type =~ /\*$/);
889 # This converts only the guys which do not have trailing part in the typedef
890 if (not $out
891 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
892 $type = normalize_type($type);
893 print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
894 if $opt_d;
895 $out = td_is_pointer($type);
896 }
897 return ($pointer_typedefs{$otype} = $out);
898}
899
900sub td_is_struct {
901 my $type = shift;
902 my $out = $struct_typedefs{$type};
903 return $out if defined $out;
904 my $otype = $type;
905 $out = ($type =~ /^struct\b/) && !td_is_pointer($type);
906 # This converts only the guys which do not have trailing part in the typedef
907 if (not $out
908 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
909 $type = normalize_type($type);
910 print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
911 if $opt_d;
912 $out = td_is_struct($type);
913 }
914 return ($struct_typedefs{$otype} = $out);
915}
916
917# Some macros will bomb if you try to return them from a double-returning func.
918# Say, ((char *)0), or strlen (if somebody #define STRLEN strlen).
919# Fortunately, we can detect both these cases...
920sub protect_convert_to_double {
921 my $in = shift;
922 my $val;
923 return '' unless defined ($val = $seen_define{$in});
924 return '(IV)' if $known_fnames{$val};
925 # OUT_t of ((OUT_t)-1):
926 return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/;
927 td_is_pointer($2) ? '(IV)' : '';
a0d0e21e
LW
928}
929
ddf6bed1
IZ
930# For each of the generated functions, length($pref) leading
931# letters are already checked. Moreover, it is recommended that
932# the generated functions uses switch on letter at offset at least
933# $off + length($pref).
934#
935# The given list has length($pref) chars removed at front, it is
936# guarantied that $off leading chars in the rest are the same for all
937# elts of the list.
938#
939# Returns: how at which offset it was decided to make a switch, or -1 if none.
940
941sub write_const;
942
943sub write_const {
944 my ($fh, $pref, $off, $list) = (shift,shift,shift,shift);
945 my %leading;
946 my $offarg = length $pref;
947
948 if (@$list == 0) { # Can happen on the initial iteration only
949 print $fh <<"END";
a0d0e21e 950static double
3cb4da91 951constant(char *name, int len, int arg)
a0d0e21e 952{
ddf6bed1
IZ
953 errno = EINVAL;
954 return 0;
955}
a0d0e21e 956END
a0d0e21e 957 return -1;
ddf6bed1 958 }
a0d0e21e 959
ddf6bed1
IZ
960 if (@$list == 1) { # Can happen on the initial iteration only
961 my $protect = protect_convert_to_double("$pref$list->[0]");
e1666bf5 962
ddf6bed1
IZ
963 print $fh <<"END";
964static double
3cb4da91 965constant(char *name, int len, int arg)
ddf6bed1 966{
daf40514 967 errno = 0;
ddf6bed1
IZ
968 if (strEQ(name + $offarg, "$list->[0]")) { /* $pref removed */
969#ifdef $pref$list->[0]
970 return $protect$pref$list->[0];
971#else
972 errno = ENOENT;
973 return 0;
974#endif
975 }
976 errno = EINVAL;
977 return 0;
a0d0e21e 978}
ddf6bed1
IZ
979END
980 return -1;
981 }
a0d0e21e 982
ddf6bed1
IZ
983 for my $n (@$list) {
984 my $c = substr $n, $off, 1;
985 $leading{$c} = [] unless exists $leading{$c};
986 push @{$leading{$c}}, substr $n, $off + 1;
987 }
988
989 if (keys(%leading) == 1) {
990 return 1 + write_const $fh, $pref, $off + 1, $list;
991 }
992
993 my $leader = substr $list->[0], 0, $off;
3cb4da91 994 foreach my $letter (keys %leading) {
ddf6bed1
IZ
995 write_const $fh, "$pref$leader$letter", 0, $leading{$letter}
996 if @{$leading{$letter}} > 1;
997 }
a0d0e21e 998
ddf6bed1
IZ
999 my $npref = "_$pref";
1000 $npref = '' if $pref eq '';
a0d0e21e 1001
ddf6bed1 1002 print $fh <<"END";
a0d0e21e 1003static double
3cb4da91 1004constant$npref(char *name, int len, int arg)
a0d0e21e 1005{
daf40514
IZ
1006END
1007
1008 print $fh <<"END" if $npref eq '';
a0d0e21e 1009 errno = 0;
a0d0e21e
LW
1010END
1011
3cb4da91
IZ
1012 print $fh <<"END" if $off;
1013 if ($offarg + $off >= len ) {
1014 errno = EINVAL;
1015 return 0;
1016 }
1017END
e1666bf5 1018
3cb4da91 1019 print $fh <<"END";
ddf6bed1
IZ
1020 switch (name[$offarg + $off]) {
1021END
a0d0e21e 1022
3cb4da91 1023 foreach my $letter (sort keys %leading) {
ddf6bed1
IZ
1024 my $let = $letter;
1025 $let = '\0' if $letter eq '';
a0d0e21e 1026
ddf6bed1
IZ
1027 print $fh <<EOP;
1028 case '$let':
1029EOP
1030 if (@{$leading{$letter}} > 1) {
1031 # It makes sense to call a function
1032 if ($off) {
1033 print $fh <<EOP;
1034 if (!strnEQ(name + $offarg,"$leader", $off))
1035 break;
1036EOP
1037 }
1038 print $fh <<EOP;
3cb4da91 1039 return constant_$pref$leader$letter(name, len, arg);
ddf6bed1 1040EOP
7aff18a2
GS
1041 }
1042 else {
ddf6bed1
IZ
1043 # Do it ourselves
1044 my $protect
1045 = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]");
1046
1047 print $fh <<EOP;
1048 if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) { /* $pref removed */
1049#ifdef $pref$leader$letter$leading{$letter}[0]
1050 return $protect$pref$leader$letter$leading{$letter}[0];
a0d0e21e
LW
1051#else
1052 goto not_there;
1053#endif
ddf6bed1
IZ
1054 }
1055EOP
a0d0e21e 1056 }
ddf6bed1
IZ
1057 }
1058 print $fh <<"END";
a0d0e21e
LW
1059 }
1060 errno = EINVAL;
1061 return 0;
1062
1063not_there:
1064 errno = ENOENT;
1065 return 0;
1066}
1067
e1666bf5 1068END
ddf6bed1 1069
e1666bf5
TB
1070}
1071
ddf6bed1
IZ
1072if( ! $opt_c ) {
1073 print XS <<"END";
1074static int
1075not_here(char *s)
1076{
1077 croak("$module::%s not implemented on this architecture", s);
1078 return -1;
1079}
1080
1081END
1082
1083 write_const(\*XS, '', 0, \@const_names);
e1666bf5
TB
1084}
1085
3cb4da91 1086my $prefix;
ead2a595 1087$prefix = "PREFIX = $opt_p" if defined $opt_p;
3cb4da91 1088
e1666bf5
TB
1089# Now switch from C to XS by issuing the first MODULE declaration:
1090print XS <<"END";
a0d0e21e 1091
ead2a595 1092MODULE = $module PACKAGE = $module $prefix
1093
1094END
1095
1096foreach (sort keys %const_xsub) {
1097 print XS <<"END";
1098char *
1099$_()
1100
1101 CODE:
1102#ifdef $_
7aff18a2 1103 RETVAL = $_;
ead2a595 1104#else
7aff18a2 1105 croak("Your vendor has not defined the $module macro $_");
ead2a595 1106#endif
1107
1108 OUTPUT:
7aff18a2 1109 RETVAL
a0d0e21e 1110
e1666bf5 1111END
ead2a595 1112}
e1666bf5
TB
1113
1114# If a constant() function was written then output a corresponding
1115# XS declaration:
1116print XS <<"END" unless $opt_c;
1117
a0d0e21e 1118double
3cb4da91 1119constant(sv,arg)
7aff18a2 1120 PREINIT:
3cb4da91 1121 STRLEN len;
7aff18a2 1122 INPUT:
3cb4da91
IZ
1123 SV * sv
1124 char * s = SvPV(sv, len);
a0d0e21e 1125 int arg
7aff18a2 1126 CODE:
3cb4da91 1127 RETVAL = constant(s,len,arg);
7aff18a2 1128 OUTPUT:
3cb4da91 1129 RETVAL
a0d0e21e
LW
1130
1131END
a0d0e21e 1132
5273d82d 1133my %seen_decl;
ddf6bed1 1134my %typemap;
5273d82d 1135
ead2a595 1136sub print_decl {
1137 my $fh = shift;
1138 my $decl = shift;
1139 my ($type, $name, $args) = @$decl;
5273d82d
IZ
1140 return if $seen_decl{$name}++; # Need to do the same for docs as well?
1141
ead2a595 1142 my @argnames = map {$_->[1]} @$args;
ddf6bed1 1143 my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
5273d82d 1144 my @argarrays = map { $_->[4] || '' } @$args;
ead2a595 1145 my $numargs = @$args;
1146 if ($numargs and $argtypes[-1] eq '...') {
1147 $numargs--;
1148 $argnames[-1] = '...';
1149 }
1150 local $" = ', ';
ddf6bed1
IZ
1151 $type = normalize_type($type, 1);
1152
ead2a595 1153 print $fh <<"EOP";
1154
1155$type
1156$name(@argnames)
1157EOP
1158
3cb4da91 1159 for my $arg (0 .. $numargs - 1) {
ead2a595 1160 print $fh <<"EOP";
5273d82d 1161 $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
ead2a595 1162EOP
1163 }
1164}
1165
7c1d48a5
GS
1166sub print_accessors {
1167 my($fh, $name, $struct) = @_;
1168 return unless defined $struct && $name !~ /\s|_ANON/;
1169 $name = normalize_type($name);
1170 my $ptrname = normalize_type("$name *");
1171 printf $fh <<"EOF";
1172
1173MODULE = $module PACKAGE = ${name}Ptr $prefix
1174
1175EOF
1176 my @items = @$struct;
1177 while (@items) {
1178 my $item = shift @items;
1179 if ($item->[0] =~ /_ANON/) {
1180 if (defined $item->[1]) {
1181 push @items, map [
1182 $_->[0], "$item->[1]_$_->[1]", "$item->[1].$_->[1]"
1183 ], @{ $structs{$item->[0]} };
1184 } else {
1185 push @items, @{ $structs{$item->[0]} };
1186 }
1187 } else {
1188 my $type = normalize_type($item->[0]);
1189 print $fh <<"EOF";
1190$type
1191$item->[1](THIS, __value = NO_INIT)
1192 $ptrname THIS
1193 $type __value
1194 PROTOTYPE: \$;\$
1195 CODE:
1196 RETVAL = THIS->$item->[-1];
1197 if (items > 1)
1198 THIS->$item->[-1] = __value;
1199 OUTPUT:
1200 RETVAL
1201
1202EOF
1203 }
1204 }
1205}
1206
5273d82d
IZ
1207# Should be called before any actual call to normalize_type().
1208sub get_typemap {
1209 # We do not want to read ./typemap by obvios reasons.
1210 my @tm = qw(../../../typemap ../../typemap ../typemap);
1211 my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap";
1212 unshift @tm, $stdtypemap;
1213 my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
ddf6bed1
IZ
1214
1215 # Start with useful default values
1216 $typemap{float} = 'T_DOUBLE';
1217
3cb4da91 1218 foreach my $typemap (@tm) {
5273d82d
IZ
1219 next unless -e $typemap ;
1220 # skip directories, binary files etc.
1221 warn " Scanning $typemap\n";
1222 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1223 unless -T $typemap ;
1224 open(TYPEMAP, $typemap)
1225 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1226 my $mode = 'Typemap';
1227 while (<TYPEMAP>) {
1228 next if /^\s*\#/;
1229 if (/^INPUT\s*$/) { $mode = 'Input'; next; }
1230 elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; }
1231 elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1232 elsif ($mode eq 'Typemap') {
1233 next if /^\s*($|\#)/ ;
3cb4da91 1234 my ($type, $image);
ddf6bed1 1235 if ( ($type, $image) =
5273d82d
IZ
1236 /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1237 # This may reference undefined functions:
1238 and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
ddf6bed1 1239 $typemap{normalize_type($type)} = $image;
5273d82d
IZ
1240 }
1241 }
1242 }
1243 close(TYPEMAP) or die "Cannot close $typemap: $!";
1244 }
1245 %std_types = %types_seen;
1246 %types_seen = ();
1247}
1248
ead2a595 1249
ddf6bed1 1250sub normalize_type { # Second arg: do not strip const's before \*
ead2a595 1251 my $type = shift;
3cb4da91
IZ
1252 my $do_keep_deep_const = shift;
1253 # If $do_keep_deep_const this is heuristical only
1254 my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
ddf6bed1 1255 my $ignore_mods
3cb4da91
IZ
1256 = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
1257 if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately!
1258 $type =~ s/$ignore_mods//go;
7aff18a2
GS
1259 }
1260 else {
3cb4da91
IZ
1261 $type =~ s/$ignore_mods//go;
1262 }
ddf6bed1 1263 $type =~ s/([^\s\w])/ \1 /g;
ead2a595 1264 $type =~ s/\s+$//;
1265 $type =~ s/^\s+//;
ddf6bed1
IZ
1266 $type =~ s/\s+/ /g;
1267 $type =~ s/\* (?=\*)/*/g;
1268 $type =~ s/\. \. \./.../g;
1269 $type =~ s/ ,/,/g;
5273d82d
IZ
1270 $types_seen{$type}++
1271 unless $type eq '...' or $type eq 'void' or $std_types{$type};
ead2a595 1272 $type;
1273}
1274
ddf6bed1
IZ
1275my $need_opaque;
1276
1277sub assign_typemap_entry {
1278 my $type = shift;
1279 my $otype = $type;
1280 my $entry;
1281 if ($tmask and $type =~ /$tmask/) {
1282 print "Type $type matches -o mask\n" if $opt_d;
1283 $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1284 }
1285 elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1286 $type = normalize_type $type;
1287 print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1288 $entry = assign_typemap_entry($type);
1289 }
1290 $entry ||= $typemap{$otype}
1291 || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1292 $typemap{$otype} = $entry;
1293 $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1294 return $entry;
1295}
1296
ead2a595 1297if ($opt_x) {
3cb4da91 1298 for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
7c1d48a5
GS
1299 if ($opt_a) {
1300 while (my($name, $struct) = each %structs) {
1301 print_accessors(\*XS, $name, $struct);
1302 }
1303 }
ead2a595 1304}
1305
a0d0e21e 1306close XS;
5273d82d
IZ
1307
1308if (%types_seen) {
1309 my $type;
1310 warn "Writing $ext$modpname/typemap\n";
1311 open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1312
3cb4da91 1313 for $type (sort keys %types_seen) {
ddf6bed1
IZ
1314 my $entry = assign_typemap_entry $type;
1315 print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
5273d82d
IZ
1316 }
1317
ddf6bed1
IZ
1318 print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1319#############################################################################
1320INPUT
1321T_OPAQUE_STRUCT
1322 if (sv_derived_from($arg, \"${ntype}\")) {
1323 STRLEN len;
1324 char *s = SvPV((SV*)SvRV($arg), len);
1325
1326 if (len != sizeof($var))
1327 croak(\"Size %d of packed data != expected %d\",
1328 len, sizeof($var));
1329 $var = *($type *)s;
1330 }
1331 else
1332 croak(\"$var is not of type ${ntype}\")
1333#############################################################################
1334OUTPUT
1335T_OPAQUE_STRUCT
1336 sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1337EOP
1338
5273d82d
IZ
1339 close TM or die "Cannot close typemap file for write: $!";
1340}
1341
2920c5d2 1342} # if( ! $opt_X )
e1666bf5 1343
8e07c86e
AD
1344warn "Writing $ext$modpname/Makefile.PL\n";
1345open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
a0d0e21e 1346
8bc03d0d 1347print PL <<END;
a0d0e21e
LW
1348use ExtUtils::MakeMaker;
1349# See lib/ExtUtils/MakeMaker.pm for details of how to influence
42793c05 1350# the contents of the Makefile that is written.
8bc03d0d
GS
1351WriteMakefile(
1352 'NAME' => '$module',
1353 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION
1354 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
a0d0e21e 1355END
8bc03d0d 1356if (!$opt_X) { # print C stuff, unless XS is disabled
ddf6bed1 1357 $opt_F = '' unless defined $opt_F;
8bc03d0d
GS
1358 print PL <<END;
1359 'LIBS' => ['$extralibs'], # e.g., '-lm'
1360 'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING'
1361 'INC' => '', # e.g., '-I/usr/include/other'
1362END
2920c5d2 1363}
a0d0e21e 1364print PL ");\n";
f508c652 1365close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
1366
1367warn "Writing $ext$modpname/test.pl\n";
1368open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
1369print EX <<'_END_';
1370# Before `make install' is performed this script should be runnable with
1371# `make test'. After `make install' it should work as `perl test.pl'
1372
1373######################### We start with some black magic to print on failure.
1374
1375# Change 1..1 below to 1..last_test_to_print .
1376# (It may become useful if the test is moved to ./t subdirectory.)
1377
5ae7f1db 1378BEGIN { $| = 1; print "1..1\n"; }
f508c652 1379END {print "not ok 1\n" unless $loaded;}
1380_END_
1381print EX <<_END_;
1382use $module;
1383_END_
1384print EX <<'_END_';
1385$loaded = 1;
1386print "ok 1\n";
1387
1388######################### End of black magic.
1389
1390# Insert your test code below (better if it prints "ok 13"
1391# (correspondingly "not ok 13") depending on the success of chunk 13
1392# of the test code):
e1666bf5 1393
f508c652 1394_END_
1395close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
a0d0e21e 1396
c0f8b9cd 1397unless ($opt_C) {
ddf6bed1
IZ
1398 warn "Writing $ext$modpname/Changes\n";
1399 $" = ' ';
1400 open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
1401 @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
1402 print EX <<EOP;
1403Revision history for Perl extension $module.
1404
1405$TEMPLATE_VERSION @{[scalar localtime]}
1406\t- original version; created by h2xs $H2XS_VERSION with options
1407\t\t@ARGS
1408
1409EOP
1410 close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
c0f8b9cd 1411}
c07a80fd 1412
1413warn "Writing $ext$modpname/MANIFEST\n";
5ae7f1db 1414open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
3cb4da91 1415my @files = <*>;
5ae7f1db 1416if (!@files) {
1417 eval {opendir(D,'.');};
1418 unless ($@) { @files = readdir(D); closedir(D); }
1419}
1420if (!@files) { @files = map {chomp && $_} `ls`; }
55497cff 1421if ($^O eq 'VMS') {
1422 foreach (@files) {
1423 # Clip trailing '.' for portability -- non-VMS OSs don't expect it
1424 s%\.$%%;
1425 # Fix up for case-sensitive file systems
1426 s/$modfname/$modfname/i && next;
1427 $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
bbce6d69 1428 $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
55497cff 1429 }
1430}
3e3baf6d 1431print MANI join("\n",@files), "\n";
5ae7f1db 1432close MANI;
40000a8c 1433!NO!SUBS!
4633a7c4
LW
1434
1435close OUT or die "Can't close $file: $!";
1436chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1437exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1 1438chdir $origdir;