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