This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix for bugs in -x mode
[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
PP
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
PP
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
a887ff11 44B<h2xs> [B<-AOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]]
f508c652
PP
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
PP
73Omit all autoload facilities. This is the same as B<-c> but also removes the
74S<C<require AutoLoader>> statement from the .pm file.
3edbfbe5 75
b73edd97
PP
76=item B<-F>
77
78Additional flags to specify to C preprocessor when scanning header for
79function declarations. Should not be used without B<-x>.
80
2920c5d2
PP
81=item B<-O>
82
83Allows a pre-existing extension directory to be overwritten.
84
f508c652 85=item B<-P>
3edbfbe5 86
f508c652 87Omit the autogenerated stub POD section.
3edbfbe5 88
b73edd97
PP
89=item B<-X>
90
91Omit the XS portion. Used to generate templates for a module which is not
92XS-based.
93
3edbfbe5
TB
94=item B<-c>
95
96Omit C<constant()> from the .xs file and corresponding specialised
97C<AUTOLOAD> from the .pm file.
98
b73edd97
PP
99=item B<-d>
100
101Turn on debugging messages.
102
f508c652 103=item B<-f>
3edbfbe5 104
f508c652
PP
105Allows an extension to be created for a header even if that header is
106not found in /usr/include.
107
108=item B<-h>
109
110Print the usage, help and version for this h2xs and exit.
111
112=item B<-n> I<module_name>
113
114Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
115
ead2a595
PP
116=item B<-p> I<prefix>
117
118Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_>
119This sets up the XS B<PREFIX> keyword and removes the prefix from functions that are
120autoloaded via the C<constant()> mechansim.
121
122=item B<-s> I<sub1,sub2>
123
124Create a perl subroutine for the specified macros rather than autoload with the constant() subroutine.
125These macros are assumed to have a return type of B<char *>, e.g., S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
126
f508c652
PP
127=item B<-v> I<version>
128
129Specify a version number for this extension. This version number is added
130to the templates. The default is 0.01.
3edbfbe5 131
760ac839
LW
132=item B<-x>
133
134Automatically generate XSUBs basing on function declarations in the
135header file. The package C<C::Scan> should be installed. If this
136option is specified, the name of the header file may look like
137C<NAME1,NAME2>. In this case NAME1 is used instead of the specified string,
b73edd97 138but XSUBs are emitted only for the declarations included from file NAME2.
760ac839 139
5273d82d
IZ
140Note that some types of arguments/return-values for functions may
141result in XSUB-declarations/typemap-entries which need
142hand-editing. Such may be objects which cannot be converted from/to a
143pointer (like C<long long>), pointers to functions, or arrays.
144
3edbfbe5
TB
145=back
146
147=head1 EXAMPLES
148
149
150 # Default behavior, extension is Rusers
151 h2xs rpcsvc/rusers
152
153 # Same, but extension is RUSERS
154 h2xs -n RUSERS rpcsvc/rusers
155
156 # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
157 h2xs rpcsvc::rusers
158
159 # Extension is ONC::RPC. Still finds <rpcsvc/rusers.h>
160 h2xs -n ONC::RPC rpcsvc/rusers
161
162 # Without constant() or AUTOLOAD
163 h2xs -c rpcsvc/rusers
164
165 # Creates templates for an extension named RPC
166 h2xs -cfn RPC
167
168 # Extension is ONC::RPC.
169 h2xs -cfn ONC::RPC
170
171 # Makefile.PL will look for library -lrpc in
172 # additional directory /opt/net/lib
173 h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
174
ead2a595
PP
175 # Extension is DCE::rgynbase
176 # prefix "sec_rgy_" is dropped from perl function names
177 h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
178
179 # Extension is DCE::rgynbase
180 # prefix "sec_rgy_" is dropped from perl function names
181 # subroutines are created for sec_rgy_wildcard_name and sec_rgy_wildcard_sid
182 h2xs -n DCE::rgynbase -p sec_rgy_ \
183 -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
3edbfbe5 184
5273d82d 185 # Make XS without defines in perl.h, but with function declarations
760ac839
LW
186 # visible from perl.h. Name of the extension is perl1.
187 # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
188 # Extra backslashes below because the string is passed to shell.
5273d82d
IZ
189 # Note that a directory with perl header files would
190 # be added automatically to include path.
191 h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
760ac839
LW
192
193 # Same with function declaration in proto.h as visible from perl.h.
5273d82d 194 h2xs -xAn perl2 perl.h,proto.h
760ac839 195
3edbfbe5
TB
196=head1 ENVIRONMENT
197
198No environment variables are used.
199
200=head1 AUTHOR
201
202Larry Wall and others
203
204=head1 SEE ALSO
205
f508c652 206L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
3edbfbe5
TB
207
208=head1 DIAGNOSTICS
209
760ac839 210The usual warnings if it cannot read or write the files involved.
3edbfbe5
TB
211
212=cut
213
d94c7266 214my( $H2XS_VERSION ) = ' $Revision: 1.19 $ ' =~ /\$Revision:\s+([^\s]+)/;
f508c652 215my $TEMPLATE_VERSION = '0.01';
a0d0e21e
LW
216
217use Getopt::Std;
218
e1666bf5
TB
219sub usage{
220 warn "@_\n" if @_;
b73edd97 221 die "h2xs [-AOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]]
f508c652 222version: $H2XS_VERSION
3edbfbe5 223 -A Omit all autoloading facilities (implies -c).
b73edd97 224 -F Additional flags for C preprocessor (used with -x).
2920c5d2 225 -O Allow overwriting of a pre-existing extension directory.
f508c652 226 -P Omit the stub POD section.
2920c5d2 227 -X Omit the XS portion.
b73edd97
PP
228 -c Omit the constant() function and specialised AUTOLOAD from the XS file.
229 -d Turn on debugging messages.
230 -f Force creation of the extension even if the C header does not exist.
231 -h Display this help message
232 -n Specify a name to use for the extension (recommended).
233 -p Specify a prefix which should be removed from the Perl function names.
234 -s Create subroutines for specified macros.
f508c652 235 -v Specify a version number for this extension.
760ac839 236 -x Autogenerate XSUBs using C::Scan.
e1666bf5
TB
237extra_libraries
238 are any libraries that might be needed for loading the
239 extension, e.g. -lm would try to link in the math library.
f508c652 240";
e1666bf5 241}
a0d0e21e 242
a0d0e21e 243
b73edd97 244getopts("AF:OPXcdfhn:p:s:v:x") || usage;
a0d0e21e 245
e1666bf5 246usage if $opt_h;
f508c652
PP
247
248if( $opt_v ){
249 $TEMPLATE_VERSION = $opt_v;
250}
e1666bf5 251$opt_c = 1 if $opt_A;
ead2a595 252%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
a0d0e21e 253
a887ff11
BS
254while (my $arg = shift) {
255 if ($arg =~ /^-l/i) {
256 $extralibs = "$arg @ARGV";
257 last;
258 }
259 push(@path_h, $arg);
260}
e1666bf5
TB
261
262usage "Must supply header file or module name\n"
a887ff11 263 unless (@path_h or $opt_n);
e1666bf5 264
a0d0e21e 265
a887ff11
BS
266if( @path_h ){
267 foreach my $path_h (@path_h) {
268 $name ||= $path_h;
e1666bf5
TB
269 if( $path_h =~ s#::#/#g && $opt_n ){
270 warn "Nesting of headerfile ignored with -n\n";
271 }
272 $path_h .= ".h" unless $path_h =~ /\.h$/;
760ac839
LW
273 $fullpath = $path_h;
274 $path_h =~ s/,.*$// if $opt_x;
ead2a595
PP
275 if ($^O eq 'VMS') { # Consider overrides of default location
276 if ($path_h !~ m![:>\[]!) {
277 my($hadsys) = ($path_h =~ s!^sys/!!i);
278 if ($ENV{'DECC$System_Include'}) { $path_h = "DECC\$System_Include:$path_h"; }
279 elsif ($ENV{'DECC$Library_Include'}) { $path_h = "DECC\$Library_Include:$path_h"; }
280 elsif ($ENV{'GNU_CC_Include'}) { $path_h = 'GNU_CC_Include:' .
281 ($hadsys ? '[vms]' : '[000000]') . $path_h; }
282 elsif ($ENV{'VAXC$Include'}) { $path_h = "VAXC\$_Include:$path_h"; }
283 else { $path_h = "Sys\$Library:$path_h"; }
284 }
285 }
286 elsif ($^O eq 'os2') {
5273d82d
IZ
287 $path_h = "/usr/include/$path_h"
288 if $path_h !~ m#^([a-z]:)?[./]#i and -r "/usr/include/$path_h";
289 }
290 else {
291 $path_h = "/usr/include/$path_h"
292 if $path_h !~ m#^[./]# and -r "/usr/include/$path_h";
ead2a595 293 }
5273d82d
IZ
294
295 if (!$opt_c) {
296 die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h );
297 # Scan the header file (we should deal with nested header files)
298 # Record the names of simple #define constants into const_names
a887ff11 299 # Function prototypes are processed below.
5273d82d
IZ
300 open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
301 while (<CH>) {
b73edd97
PP
302 if (/^#[ \t]*define\s+([\$\w]+)\b\s*[^("]/) {
303 print "Matched $_ ($1)\n" if $opt_d;
e1666bf5
TB
304 $_ = $1;
305 next if /^_.*_h_*$/i; # special case, but for what?
760ac839 306 if (defined $opt_p) {
5273d82d
IZ
307 if (!/^$opt_p(\d)/) {
308 ++$prefix{$_} if s/^$opt_p//;
309 }
310 else {
311 warn "can't remove $opt_p prefix from '$_'!\n";
312 }
ead2a595 313 }
e1666bf5 314 $const_names{$_}++;
5273d82d
IZ
315 }
316 }
317 close(CH);
e1666bf5 318 }
a887ff11
BS
319 }
320 @const_names = sort keys %const_names;
a0d0e21e
LW
321}
322
e1666bf5 323
a0d0e21e
LW
324$module = $opt_n || do {
325 $name =~ s/\.h$//;
326 if( $name !~ /::/ ){
327 $name =~ s#^.*/##;
328 $name = "\u$name";
329 }
330 $name;
331};
332
8e07c86e 333(chdir 'ext', $ext = 'ext/') if -d 'ext';
a0d0e21e
LW
334
335if( $module =~ /::/ ){
336 $nested = 1;
337 @modparts = split(/::/,$module);
338 $modfname = $modparts[-1];
339 $modpname = join('/',@modparts);
340}
341else {
342 $nested = 0;
343 @modparts = ();
344 $modfname = $modpname = $module;
345}
346
347
2920c5d2
PP
348if ($opt_O) {
349 warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
350} else {
351 die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
352}
c07a80fd
PP
353if( $nested ){
354 $modpath = "";
355 foreach (@modparts){
356 mkdir("$modpath$_", 0777);
357 $modpath .= "$_/";
358 }
359}
a0d0e21e 360mkdir($modpname, 0777);
8e07c86e 361chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
a0d0e21e 362
5273d82d
IZ
363my %types_seen;
364my %std_types;
f4d63e4e
IZ
365my $fdecls = [];
366my $fdecls_parsed = [];
5273d82d 367
2920c5d2
PP
368if( ! $opt_X ){ # use XS, unless it was disabled
369 open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
5273d82d
IZ
370 if ($opt_x) {
371 require C::Scan; # Run-time directive
372 require Config; # Run-time directive
373 warn "Scanning typemaps...\n";
374 get_typemap();
375 my $c;
376 my $filter;
f4d63e4e
IZ
377 foreach my $filename (@path_h) {
378 my $addflags = $opt_F || '';
379 if ($fullpath =~ /,/) {
380 $filename = $`;
381 $filter = $';
382 }
383 warn "Scanning $filename for functions...\n";
384 $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
385 'add_cppflags' => $addflags;
386 $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
387
388 push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
389 push(@$fdecls, @{$c->get('fdecls')});
5273d82d 390 }
5273d82d 391 }
2920c5d2 392}
5273d82d 393
8e07c86e 394open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
a0d0e21e 395
a0d0e21e 396$" = "\n\t";
8e07c86e 397warn "Writing $ext$modpname/$modfname.pm\n";
a0d0e21e 398
a0d0e21e
LW
399print PM <<"END";
400package $module;
401
2920c5d2
PP
402use strict;
403END
404
405if( $opt_X || $opt_c || $opt_A ){
406 # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD
407 print PM <<'END';
f192e801 408use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
2920c5d2
PP
409END
410}
411else{
412 # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
413 # will want Carp.
414 print PM <<'END';
415use Carp;
f192e801 416use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
2920c5d2
PP
417END
418}
419
420print PM <<'END';
421
a0d0e21e 422require Exporter;
2920c5d2
PP
423END
424
425print PM <<"END" if ! $opt_X; # use DynaLoader, unless XS was disabled
a0d0e21e 426require DynaLoader;
3edbfbe5
TB
427END
428
2920c5d2
PP
429# require autoloader if XS is disabled.
430# if XS is enabled, require autoloader unless autoloading is disabled.
464ed3b6 431if( ($opt_X && (! $opt_A)) || (!$opt_X) ) {
3edbfbe5
TB
432 print PM <<"END";
433require AutoLoader;
434END
435}
436
2920c5d2 437if( $opt_X || ($opt_c && ! $opt_A) ){
3edbfbe5 438 # we won't have our own AUTOLOAD(), so we'll inherit it.
2920c5d2
PP
439 if( ! $opt_X ) { # use DynaLoader, unless XS was disabled
440 print PM <<"END";
e1666bf5 441
a0d0e21e 442\@ISA = qw(Exporter AutoLoader DynaLoader);
3edbfbe5 443END
2920c5d2
PP
444 }
445 else{
446 print PM <<"END";
447
448\@ISA = qw(Exporter AutoLoader);
449END
450 }
3edbfbe5
TB
451}
452else{
453 # 1) we have our own AUTOLOAD(), so don't need to inherit it.
454 # or
455 # 2) we don't want autoloading mentioned.
2920c5d2
PP
456 if( ! $opt_X ){ # use DynaLoader, unless XS was disabled
457 print PM <<"END";
3edbfbe5
TB
458
459\@ISA = qw(Exporter DynaLoader);
460END
2920c5d2
PP
461 }
462 else{
463 print PM <<"END";
464
465\@ISA = qw(Exporter);
466END
467 }
3edbfbe5 468}
e1666bf5 469
3edbfbe5 470print PM<<"END";
e1666bf5
TB
471# Items to export into callers namespace by default. Note: do not export
472# names by default without a very good reason. Use EXPORT_OK instead.
473# Do not simply export all your public functions/methods/constants.
a0d0e21e 474\@EXPORT = qw(
e1666bf5 475 @const_names
a0d0e21e 476);
f508c652
PP
477\$VERSION = '$TEMPLATE_VERSION';
478
e1666bf5
TB
479END
480
2920c5d2 481print PM <<"END" unless $opt_c or $opt_X;
a0d0e21e 482sub AUTOLOAD {
3edbfbe5
TB
483 # This AUTOLOAD is used to 'autoload' constants from the constant()
484 # XS function. If a constant is not found then control is passed
485 # to the AUTOLOAD in AutoLoader.
e1666bf5 486
2920c5d2 487 my \$constname;
a0d0e21e 488 (\$constname = \$AUTOLOAD) =~ s/.*:://;
1d3434b8 489 croak "&$module::constant not defined" if \$constname eq 'constant';
2920c5d2 490 my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
a0d0e21e
LW
491 if (\$! != 0) {
492 if (\$! =~ /Invalid/) {
493 \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
494 goto &AutoLoader::AUTOLOAD;
495 }
496 else {
2920c5d2 497 croak "Your vendor has not defined $module macro \$constname";
a0d0e21e
LW
498 }
499 }
1d3434b8 500 *\$AUTOLOAD = sub () { \$val };
a0d0e21e
LW
501 goto &\$AUTOLOAD;
502}
503
a0d0e21e 504END
a0d0e21e 505
2920c5d2
PP
506if( ! $opt_X ){ # print bootstrap, unless XS is disabled
507 print PM <<"END";
f508c652 508bootstrap $module \$VERSION;
2920c5d2
PP
509END
510}
511
512if( $opt_P ){ # if POD is disabled
513 $after = '__END__';
514}
515else {
516 $after = '=cut';
517}
518
519print PM <<"END";
a0d0e21e 520
e1666bf5 521# Preloaded methods go here.
a0d0e21e 522
2920c5d2 523# Autoload methods go after $after, and are processed by the autosplit program.
a0d0e21e
LW
524
5251;
e1666bf5 526__END__
a0d0e21e 527END
a0d0e21e 528
f508c652
PP
529$author = "A. U. Thor";
530$email = 'a.u.thor@a.galaxy.far.far.away';
531
5273d82d
IZ
532my $const_doc = '';
533my $fdecl_doc = '';
534if (@const_names and not $opt_P) {
535 $const_doc = <<EOD;
b73edd97 536\n=head1 Exported constants
5273d82d
IZ
537
538 @{[join "\n ", @const_names]}
539
540EOD
541}
542if (defined $fdecls and @$fdecls and not $opt_P) {
543 $fdecl_doc = <<EOD;
b73edd97 544\n=head1 Exported functions
5273d82d
IZ
545
546 @{[join "\n ", @$fdecls]}
547
548EOD
549}
550
f508c652
PP
551$pod = <<"END" unless $opt_P;
552## Below is the stub of documentation for your module. You better edit it!
553#
554#=head1 NAME
555#
556#$module - Perl extension for blah blah blah
557#
558#=head1 SYNOPSIS
559#
560# use $module;
561# blah blah blah
562#
563#=head1 DESCRIPTION
564#
565#Stub documentation for $module was created by h2xs. It looks like the
566#author of the extension was negligent enough to leave the stub
567#unedited.
568#
569#Blah blah blah.
5273d82d 570#$const_doc$fdecl_doc
f508c652
PP
571#=head1 AUTHOR
572#
573#$author, $email
574#
575#=head1 SEE ALSO
576#
577#perl(1).
578#
579#=cut
580END
581
582$pod =~ s/^\#//gm unless $opt_P;
583print PM $pod unless $opt_P;
584
a0d0e21e
LW
585close PM;
586
e1666bf5 587
2920c5d2 588if( ! $opt_X ){ # print XS, unless it is disabled
8e07c86e 589warn "Writing $ext$modpname/$modfname.xs\n";
e1666bf5 590
a0d0e21e
LW
591print XS <<"END";
592#include "EXTERN.h"
593#include "perl.h"
594#include "XSUB.h"
595
596END
a887ff11
BS
597if( @path_h ){
598 foreach my $path_h (@path_h) {
a0d0e21e
LW
599 my($h) = $path_h;
600 $h =~ s#^/usr/include/##;
ead2a595 601 if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
a887ff11
BS
602 print XS qq{#include <$h>\n};
603 }
604 print XS "\n";
a0d0e21e
LW
605}
606
607if( ! $opt_c ){
608print XS <<"END";
609static int
d94c7266 610not_here(char *s)
a0d0e21e
LW
611{
612 croak("$module::%s not implemented on this architecture", s);
613 return -1;
614}
615
616static double
d94c7266 617constant(char *name, int arg)
a0d0e21e
LW
618{
619 errno = 0;
620 switch (*name) {
621END
622
e1666bf5
TB
623my(@AZ, @az, @under);
624
625foreach(@const_names){
626 @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/;
627 @az = 'a' .. 'z' if !@az && /^[a-z]/;
628 @under = '_' if !@under && /^_/;
629}
630
a0d0e21e
LW
631foreach $letter (@AZ, @az, @under) {
632
e1666bf5 633 last if $letter eq 'a' && !@const_names;
a0d0e21e
LW
634
635 print XS " case '$letter':\n";
636 my($name);
e1666bf5
TB
637 while (substr($const_names[0],0,1) eq $letter) {
638 $name = shift(@const_names);
ead2a595
PP
639 $macro = $prefix{$name} ? "$opt_p$name" : $name;
640 next if $const_xsub{$macro};
a0d0e21e
LW
641 print XS <<"END";
642 if (strEQ(name, "$name"))
ead2a595
PP
643#ifdef $macro
644 return $macro;
a0d0e21e
LW
645#else
646 goto not_there;
647#endif
648END
649 }
650 print XS <<"END";
651 break;
652END
653}
654print XS <<"END";
655 }
656 errno = EINVAL;
657 return 0;
658
659not_there:
660 errno = ENOENT;
661 return 0;
662}
663
e1666bf5
TB
664END
665}
666
ead2a595 667$prefix = "PREFIX = $opt_p" if defined $opt_p;
e1666bf5
TB
668# Now switch from C to XS by issuing the first MODULE declaration:
669print XS <<"END";
a0d0e21e 670
ead2a595
PP
671MODULE = $module PACKAGE = $module $prefix
672
673END
674
675foreach (sort keys %const_xsub) {
676 print XS <<"END";
677char *
678$_()
679
680 CODE:
681#ifdef $_
682 RETVAL = $_;
683#else
684 croak("Your vendor has not defined the $module macro $_");
685#endif
686
687 OUTPUT:
688 RETVAL
a0d0e21e 689
e1666bf5 690END
ead2a595 691}
e1666bf5
TB
692
693# If a constant() function was written then output a corresponding
694# XS declaration:
695print XS <<"END" unless $opt_c;
696
a0d0e21e
LW
697double
698constant(name,arg)
699 char * name
700 int arg
701
702END
a0d0e21e 703
5273d82d
IZ
704my %seen_decl;
705
706
ead2a595
PP
707sub print_decl {
708 my $fh = shift;
709 my $decl = shift;
710 my ($type, $name, $args) = @$decl;
5273d82d
IZ
711 return if $seen_decl{$name}++; # Need to do the same for docs as well?
712
ead2a595
PP
713 my @argnames = map {$_->[1]} @$args;
714 my @argtypes = map { normalize_type( $_->[0] ) } @$args;
5273d82d 715 my @argarrays = map { $_->[4] || '' } @$args;
ead2a595
PP
716 my $numargs = @$args;
717 if ($numargs and $argtypes[-1] eq '...') {
718 $numargs--;
719 $argnames[-1] = '...';
720 }
721 local $" = ', ';
722 $type = normalize_type($type);
723
724 print $fh <<"EOP";
725
726$type
727$name(@argnames)
728EOP
729
730 for $arg (0 .. $numargs - 1) {
731 print $fh <<"EOP";
5273d82d 732 $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
ead2a595
PP
733EOP
734 }
735}
736
5273d82d
IZ
737# Should be called before any actual call to normalize_type().
738sub get_typemap {
739 # We do not want to read ./typemap by obvios reasons.
740 my @tm = qw(../../../typemap ../../typemap ../typemap);
741 my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap";
742 unshift @tm, $stdtypemap;
743 my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
744 my $image;
745
746 foreach $typemap (@tm) {
747 next unless -e $typemap ;
748 # skip directories, binary files etc.
749 warn " Scanning $typemap\n";
750 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
751 unless -T $typemap ;
752 open(TYPEMAP, $typemap)
753 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
754 my $mode = 'Typemap';
755 while (<TYPEMAP>) {
756 next if /^\s*\#/;
757 if (/^INPUT\s*$/) { $mode = 'Input'; next; }
758 elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; }
759 elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
760 elsif ($mode eq 'Typemap') {
761 next if /^\s*($|\#)/ ;
762 if ( ($type, $image) =
763 /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
764 # This may reference undefined functions:
765 and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
766 normalize_type($type);
767 }
768 }
769 }
770 close(TYPEMAP) or die "Cannot close $typemap: $!";
771 }
772 %std_types = %types_seen;
773 %types_seen = ();
774}
775
ead2a595
PP
776
777sub normalize_type {
5273d82d 778 my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*';
ead2a595
PP
779 my $type = shift;
780 $type =~ s/$ignore_mods//go;
5273d82d 781 $type =~ s/([\]\[()])/ \1 /g;
ead2a595
PP
782 $type =~ s/\s+/ /g;
783 $type =~ s/\s+$//;
784 $type =~ s/^\s+//;
785 $type =~ s/\b\*/ */g;
786 $type =~ s/\*\b/* /g;
787 $type =~ s/\*\s+(?=\*)/*/g;
5273d82d
IZ
788 $types_seen{$type}++
789 unless $type eq '...' or $type eq 'void' or $std_types{$type};
ead2a595
PP
790 $type;
791}
792
793if ($opt_x) {
5273d82d 794 for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
ead2a595
PP
795}
796
a0d0e21e 797close XS;
5273d82d
IZ
798
799if (%types_seen) {
800 my $type;
801 warn "Writing $ext$modpname/typemap\n";
802 open TM, ">typemap" or die "Cannot open typemap file for write: $!";
803
804 for $type (keys %types_seen) {
805 print TM $type, "\t" x (6 - int((length $type)/8)), "T_PTROBJ\n"
806 }
807
808 close TM or die "Cannot close typemap file for write: $!";
809}
810
2920c5d2 811} # if( ! $opt_X )
e1666bf5 812
8e07c86e
AD
813warn "Writing $ext$modpname/Makefile.PL\n";
814open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
a0d0e21e 815
a0d0e21e
LW
816print PL <<'END';
817use ExtUtils::MakeMaker;
818# See lib/ExtUtils/MakeMaker.pm for details of how to influence
42793c05 819# the contents of the Makefile that is written.
a0d0e21e 820END
42793c05
TB
821print PL "WriteMakefile(\n";
822print PL " 'NAME' => '$module',\n";
c07a80fd 823print PL " 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n";
2920c5d2
PP
824if( ! $opt_X ){ # print C stuff, unless XS is disabled
825 print PL " 'LIBS' => ['$extralibs'], # e.g., '-lm' \n";
826 print PL " 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' \n";
827 print PL " 'INC' => '', # e.g., '-I/usr/include/other' \n";
828}
a0d0e21e 829print PL ");\n";
f508c652
PP
830close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
831
832warn "Writing $ext$modpname/test.pl\n";
833open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
834print EX <<'_END_';
835# Before `make install' is performed this script should be runnable with
836# `make test'. After `make install' it should work as `perl test.pl'
837
838######################### We start with some black magic to print on failure.
839
840# Change 1..1 below to 1..last_test_to_print .
841# (It may become useful if the test is moved to ./t subdirectory.)
842
5ae7f1db 843BEGIN { $| = 1; print "1..1\n"; }
f508c652
PP
844END {print "not ok 1\n" unless $loaded;}
845_END_
846print EX <<_END_;
847use $module;
848_END_
849print EX <<'_END_';
850$loaded = 1;
851print "ok 1\n";
852
853######################### End of black magic.
854
855# Insert your test code below (better if it prints "ok 13"
856# (correspondingly "not ok 13") depending on the success of chunk 13
857# of the test code):
e1666bf5 858
f508c652
PP
859_END_
860close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
a0d0e21e 861
c07a80fd
PP
862warn "Writing $ext$modpname/Changes\n";
863open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
864print EX "Revision history for Perl extension $module.\n\n";
865print EX "$TEMPLATE_VERSION ",scalar localtime,"\n";
866print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n";
867close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
868
869warn "Writing $ext$modpname/MANIFEST\n";
5ae7f1db
PP
870open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
871@files = <*>;
872if (!@files) {
873 eval {opendir(D,'.');};
874 unless ($@) { @files = readdir(D); closedir(D); }
875}
876if (!@files) { @files = map {chomp && $_} `ls`; }
55497cff
PP
877if ($^O eq 'VMS') {
878 foreach (@files) {
879 # Clip trailing '.' for portability -- non-VMS OSs don't expect it
880 s%\.$%%;
881 # Fix up for case-sensitive file systems
882 s/$modfname/$modfname/i && next;
883 $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
bbce6d69 884 $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
55497cff
PP
885 }
886}
3e3baf6d 887print MANI join("\n",@files), "\n";
5ae7f1db 888close MANI;
40000a8c 889!NO!SUBS!
4633a7c4
LW
890
891close OUT or die "Can't close $file: $!";
892chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
893exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1 894chdir $origdir;