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