This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate with Sarathy.
[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)
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
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
ddf6bed1 305my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/;
f508c652 306my $TEMPLATE_VERSION = '0.01';
ddf6bed1 307my @ARGS = @ARGV;
a0d0e21e
LW
308
309use Getopt::Std;
310
e1666bf5
TB
311sub usage{
312 warn "@_\n" if @_;
c0f8b9cd 313 die "h2xs [-ACOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]]
f508c652 314version: $H2XS_VERSION
3edbfbe5 315 -A Omit all autoloading facilities (implies -c).
c0f8b9cd 316 -C Omit creating the Changes file, add HISTORY heading to stub POD.
b73edd97 317 -F Additional flags for C preprocessor (used with -x).
ddf6bed1 318 -M Mask to select C functions/macros (default is select all).
2920c5d2 319 -O Allow overwriting of a pre-existing extension directory.
f508c652 320 -P Omit the stub POD section.
9ef261b5 321 -X Omit the XS portion (implies both -c and -f).
b73edd97 322 -c Omit the constant() function and specialised AUTOLOAD from the XS file.
323 -d Turn on debugging messages.
324 -f Force creation of the extension even if the C header does not exist.
325 -h Display this help message
326 -n Specify a name to use for the extension (recommended).
ddf6bed1 327 -o Regular expression for \"opaque\" types.
b73edd97 328 -p Specify a prefix which should be removed from the Perl function names.
329 -s Create subroutines for specified macros.
f508c652 330 -v Specify a version number for this extension.
760ac839 331 -x Autogenerate XSUBs using C::Scan.
e1666bf5
TB
332extra_libraries
333 are any libraries that might be needed for loading the
334 extension, e.g. -lm would try to link in the math library.
f508c652 335";
e1666bf5 336}
a0d0e21e 337
a0d0e21e 338
ddf6bed1 339getopts("ACF:M:OPXcdfhn:o:p:s:v:x") || usage;
a0d0e21e 340
e1666bf5 341usage if $opt_h;
f508c652 342
343if( $opt_v ){
344 $TEMPLATE_VERSION = $opt_v;
345}
9ef261b5
MS
346
347# -A implies -c.
e1666bf5 348$opt_c = 1 if $opt_A;
9ef261b5
MS
349
350# -X implies -c and -f
351$opt_c = $opt_f = 1 if $opt_X;
352
ead2a595 353%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
a0d0e21e 354
a887ff11
BS
355while (my $arg = shift) {
356 if ($arg =~ /^-l/i) {
357 $extralibs = "$arg @ARGV";
358 last;
359 }
360 push(@path_h, $arg);
361}
e1666bf5
TB
362
363usage "Must supply header file or module name\n"
a887ff11 364 unless (@path_h or $opt_n);
e1666bf5 365
ddf6bed1
IZ
366my $fmask;
367my $omask;
368
369$fmask = qr{$opt_M} if defined $opt_M;
370$tmask = qr{$opt_o} if defined $opt_o;
371my $tmask_all = $tmask && $opt_o eq '.';
372
373if ($opt_x) {
374 eval {require C::Scan; 1}
375 or die <<EOD;
376C::Scan required if you use -x option.
377To install C::Scan, execute
378 perl -MCPAN -e "install C::Scan"
379EOD
380 unless ($tmask_all) {
381 $C::Scan::VERSION >= 0.70
382 or die <<EOD;
383C::Scan v. 0.70 or later required unless you use -o . option.
384You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
385To install C::Scan, execute
386 perl -MCPAN -e "install C::Scan"
387EOD
388 }
389} elsif ($opt_o or $opt_F) {
390 warn <<EOD;
391Options -o and -F do not make sense without -x.
392EOD
393}
394
395my %seen_define;
396my %prefixless;
a0d0e21e 397
a887ff11 398if( @path_h ){
ddf6bed1
IZ
399 use Config;
400 use File::Spec;
401 my @paths;
402 if ($^O eq 'VMS') { # Consider overrides of default location
403 @paths = qw( Sys\$Library VAXC$Include );
404 push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
405 push @paths, qw( DECC$Library_Include DECC$System_Include );
406 } else {
407 @paths = (File::Spec->curdir(), $Config{usrinc},
408 (split ' ', $Config{locincpth}), '/usr/include');
409 }
a887ff11
BS
410 foreach my $path_h (@path_h) {
411 $name ||= $path_h;
e1666bf5
TB
412 if( $path_h =~ s#::#/#g && $opt_n ){
413 warn "Nesting of headerfile ignored with -n\n";
414 }
415 $path_h .= ".h" unless $path_h =~ /\.h$/;
760ac839
LW
416 $fullpath = $path_h;
417 $path_h =~ s/,.*$// if $opt_x;
ddf6bed1
IZ
418
419 if (not -f $path_h) {
420 my $tmp_path_h = $path_h;
421 for my $dir (@paths) {
422 last if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
423 }
ead2a595 424 }
5273d82d
IZ
425
426 if (!$opt_c) {
427 die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h );
428 # Scan the header file (we should deal with nested header files)
429 # Record the names of simple #define constants into const_names
a887ff11 430 # Function prototypes are processed below.
5273d82d 431 open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
ddf6bed1 432 defines:
5273d82d 433 while (<CH>) {
ddf6bed1
IZ
434 if (/^#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) {
435 my $def = $1;
436 my $rest = $2;
437 $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
438 $rest =~ s/^\s+//;
439 $rest =~ s/\s+$//;
440 # Cannot do: (-1) and ((LHANDLE)3) are OK:
441 #print("Skip non-wordy $def => $rest\n"),
442 # next defines if $rest =~ /[^\w\$]/;
443 if ($rest =~ /"/) {
444 print("Skip stringy $def => $rest\n") if $opt_d;
445 next defines;
446 }
447 print "Matched $_ ($def)\n" if $opt_d;
448 $seen_define{$def} = $rest;
449 $_ = $def;
e1666bf5 450 next if /^_.*_h_*$/i; # special case, but for what?
760ac839 451 if (defined $opt_p) {
5273d82d
IZ
452 if (!/^$opt_p(\d)/) {
453 ++$prefix{$_} if s/^$opt_p//;
454 }
455 else {
456 warn "can't remove $opt_p prefix from '$_'!\n";
457 }
ead2a595 458 }
ddf6bed1
IZ
459 $prefixless{$def} = $_;
460 if (!$fmask or /$fmask/) {
461 print "... Passes mask of -M.\n" if $opt_d and $fmask;
462 $const_names{$_}++;
463 }
5273d82d
IZ
464 }
465 }
466 close(CH);
e1666bf5 467 }
a887ff11 468 }
a0d0e21e
LW
469}
470
e1666bf5 471
a0d0e21e
LW
472$module = $opt_n || do {
473 $name =~ s/\.h$//;
474 if( $name !~ /::/ ){
475 $name =~ s#^.*/##;
476 $name = "\u$name";
477 }
478 $name;
479};
480
8e07c86e 481(chdir 'ext', $ext = 'ext/') if -d 'ext';
a0d0e21e
LW
482
483if( $module =~ /::/ ){
484 $nested = 1;
485 @modparts = split(/::/,$module);
486 $modfname = $modparts[-1];
487 $modpname = join('/',@modparts);
488}
489else {
490 $nested = 0;
491 @modparts = ();
492 $modfname = $modpname = $module;
493}
494
495
2920c5d2 496if ($opt_O) {
497 warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
498} else {
499 die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
500}
c07a80fd 501if( $nested ){
502 $modpath = "";
503 foreach (@modparts){
504 mkdir("$modpath$_", 0777);
505 $modpath .= "$_/";
506 }
507}
a0d0e21e 508mkdir($modpname, 0777);
8e07c86e 509chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
a0d0e21e 510
5273d82d
IZ
511my %types_seen;
512my %std_types;
f4d63e4e
IZ
513my $fdecls = [];
514my $fdecls_parsed = [];
ddf6bed1
IZ
515my $typedef_rex;
516my %typedefs_pre;
517my %known_fnames;
5273d82d 518
2920c5d2 519if( ! $opt_X ){ # use XS, unless it was disabled
520 open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
5273d82d 521 if ($opt_x) {
5273d82d
IZ
522 require Config; # Run-time directive
523 warn "Scanning typemaps...\n";
524 get_typemap();
525 my $c;
526 my $filter;
f4d63e4e
IZ
527 foreach my $filename (@path_h) {
528 my $addflags = $opt_F || '';
529 if ($fullpath =~ /,/) {
530 $filename = $`;
531 $filter = $';
532 }
533 warn "Scanning $filename for functions...\n";
534 $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
535 'add_cppflags' => $addflags;
536 $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
ddf6bed1 537
f4d63e4e
IZ
538 push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
539 push(@$fdecls, @{$c->get('fdecls')});
5273d82d 540 }
ddf6bed1
IZ
541 %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
542 if ($fmask) {
543 my @good;
544 for my $i (0..$#$fdecls_parsed) {
545 next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
546 push @good, $i;
547 print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
548 if $opt_d;
549 }
550 $fdecls = [@$fdecls[@good]];
551 $fdecls_parsed = [@$fdecls_parsed[@good]];
552 }
553 unless ($tmask_all) {
554 warn "Scanning $filename for typedefs...\n";
555 my $td = $c->get('typedef_hash');
556 # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
557 my @good_td = grep $td->{$_}[1] eq '', keys %$td;
558 @typedefs_pre{@good_td} = map $_->[0], @$td{@good_td};
559 { local $" = '|';
560 $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b);
561 }
562 }
563 # Remove macros which expand to typedefs
564 my @td = @{$c->get('typedefs_maybe')};
565 print "Typedefs are @td.\n" if $opt_d;
566 my %td = map {($_, $_)} @td;
567 # Add some other possible but meaningless values for macros
568 for my $k (qw(char double float int long short unsigned signed void)) {
569 $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
570 }
571 # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
572 my $n = 0;
573 my %bad_macs;
574 while (keys %td > $n) {
575 $n = keys %td;
576 my ($k, $v);
577 while (($k, $v) = each %seen_define) {
578 # print("found '$k'=>'$v'\n"),
579 $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
580 }
581 }
582 # Now %bad_macs contains names of bad macros
583 for my $k (keys %bad_macs) {
584 delete $const_names{$prefixless{$k}};
585 print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
586 }
5273d82d 587 }
2920c5d2 588}
ddf6bed1 589@const_names = sort keys %const_names;
5273d82d 590
8e07c86e 591open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
a0d0e21e 592
a0d0e21e 593$" = "\n\t";
8e07c86e 594warn "Writing $ext$modpname/$modfname.pm\n";
a0d0e21e 595
a0d0e21e
LW
596print PM <<"END";
597package $module;
598
2920c5d2 599use strict;
600END
601
602if( $opt_X || $opt_c || $opt_A ){
603 # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD
604 print PM <<'END';
ddf6bed1 605use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
2920c5d2 606END
607}
608else{
609 # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
610 # will want Carp.
611 print PM <<'END';
612use Carp;
ddf6bed1 613use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);
2920c5d2 614END
615}
616
617print PM <<'END';
618
a0d0e21e 619require Exporter;
2920c5d2 620END
621
622print PM <<"END" if ! $opt_X; # use DynaLoader, unless XS was disabled
a0d0e21e 623require DynaLoader;
3edbfbe5
TB
624END
625
e1666bf5 626
9ef261b5
MS
627# Are we using AutoLoader or not?
628unless ($opt_A) { # no autoloader whatsoever.
629 unless ($opt_c) { # we're doing the AUTOLOAD
630 print PM "use AutoLoader;\n";
2920c5d2 631 }
9ef261b5
MS
632 else {
633 print PM "use AutoLoader qw(AUTOLOAD);\n"
2920c5d2 634 }
3edbfbe5 635}
3edbfbe5 636
9ef261b5
MS
637# Determine @ISA.
638my $myISA = '@ISA = qw(Exporter'; # We seem to always want this.
639$myISA .= ' DynaLoader' unless $opt_X; # no XS
640$myISA .= ');';
641print PM "\n$myISA\n\n";
e1666bf5 642
3edbfbe5 643print PM<<"END";
e1666bf5
TB
644# Items to export into callers namespace by default. Note: do not export
645# names by default without a very good reason. Use EXPORT_OK instead.
646# Do not simply export all your public functions/methods/constants.
ddf6bed1
IZ
647
648# This allows declaration use $module ':all';
649# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
650# will save memory.
651%EXPORT_TAGS = ( ':all' => [ qw(
e1666bf5 652 @const_names
ddf6bed1
IZ
653) ] );
654
655\@EXPORT_OK = ( \@{ \$EXPORT_TAGS{':all'} } );
656
657\@EXPORT = (
658
a0d0e21e 659);
f508c652 660\$VERSION = '$TEMPLATE_VERSION';
661
e1666bf5
TB
662END
663
2920c5d2 664print PM <<"END" unless $opt_c or $opt_X;
a0d0e21e 665sub AUTOLOAD {
3edbfbe5
TB
666 # This AUTOLOAD is used to 'autoload' constants from the constant()
667 # XS function. If a constant is not found then control is passed
668 # to the AUTOLOAD in AutoLoader.
e1666bf5 669
2920c5d2 670 my \$constname;
a0d0e21e 671 (\$constname = \$AUTOLOAD) =~ s/.*:://;
1d3434b8 672 croak "&$module::constant not defined" if \$constname eq 'constant';
2920c5d2 673 my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
a0d0e21e 674 if (\$! != 0) {
265f5c4a 675 if (\$! =~ /Invalid/ || \$!{EINVAL}) {
a0d0e21e
LW
676 \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
677 goto &AutoLoader::AUTOLOAD;
678 }
679 else {
2920c5d2 680 croak "Your vendor has not defined $module macro \$constname";
a0d0e21e
LW
681 }
682 }
ddf6bed1
IZ
683 { no strict 'refs';
684 # Next line doesn't help with older Perls; in newers: no such warnings
685 # local \$^W = 0; # Prototype mismatch: sub XXX vs ()
686 *\$AUTOLOAD = sub () { \$val };
687 }
a0d0e21e
LW
688 goto &\$AUTOLOAD;
689}
690
a0d0e21e 691END
a0d0e21e 692
2920c5d2 693if( ! $opt_X ){ # print bootstrap, unless XS is disabled
694 print PM <<"END";
f508c652 695bootstrap $module \$VERSION;
2920c5d2 696END
697}
698
699if( $opt_P ){ # if POD is disabled
700 $after = '__END__';
701}
702else {
703 $after = '=cut';
704}
705
706print PM <<"END";
a0d0e21e 707
e1666bf5 708# Preloaded methods go here.
9ef261b5
MS
709END
710
711print PM <<"END" unless $opt_A;
a0d0e21e 712
2920c5d2 713# Autoload methods go after $after, and are processed by the autosplit program.
9ef261b5
MS
714END
715
716print PM <<"END";
a0d0e21e
LW
717
7181;
e1666bf5 719__END__
a0d0e21e 720END
a0d0e21e 721
f508c652 722$author = "A. U. Thor";
723$email = 'a.u.thor@a.galaxy.far.far.away';
724
c0f8b9cd
GS
725my $revhist = '';
726$revhist = <<EOT if $opt_C;
727
728=head1 HISTORY
729
730=over 8
731
732=item $TEMPLATE_VERSION
733
ddf6bed1
IZ
734Original version; created by h2xs $H2XS_VERSION with options
735
736 @ARGS
c0f8b9cd
GS
737
738=back
739
740EOT
741
ddf6bed1
IZ
742my $exp_doc = <<EOD;
743
744=head2 EXPORT
745
746None by default.
747
748EOD
5273d82d 749if (@const_names and not $opt_P) {
ddf6bed1
IZ
750 $exp_doc .= <<EOD;
751=head2 Exportable constants
5273d82d
IZ
752
753 @{[join "\n ", @const_names]}
754
755EOD
756}
757if (defined $fdecls and @$fdecls and not $opt_P) {
ddf6bed1
IZ
758 my @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
759
760 $exp_doc .= <<EOD;
761=head2 Exportable functions
5273d82d 762
ddf6bed1 763 @{[join "\n ", @known_fnames{@fnames}]}
5273d82d
IZ
764
765EOD
766}
767
f508c652 768$pod = <<"END" unless $opt_P;
769## Below is the stub of documentation for your module. You better edit it!
770#
771#=head1 NAME
772#
773#$module - Perl extension for blah blah blah
774#
775#=head1 SYNOPSIS
776#
777# use $module;
778# blah blah blah
779#
780#=head1 DESCRIPTION
781#
782#Stub documentation for $module was created by h2xs. It looks like the
783#author of the extension was negligent enough to leave the stub
784#unedited.
785#
786#Blah blah blah.
ddf6bed1 787#$exp_doc$revhist
f508c652 788#=head1 AUTHOR
789#
790#$author, $email
791#
792#=head1 SEE ALSO
793#
794#perl(1).
795#
796#=cut
797END
798
799$pod =~ s/^\#//gm unless $opt_P;
800print PM $pod unless $opt_P;
801
a0d0e21e
LW
802close PM;
803
e1666bf5 804
2920c5d2 805if( ! $opt_X ){ # print XS, unless it is disabled
8e07c86e 806warn "Writing $ext$modpname/$modfname.xs\n";
e1666bf5 807
a0d0e21e
LW
808print XS <<"END";
809#include "EXTERN.h"
810#include "perl.h"
811#include "XSUB.h"
812
813END
a887ff11
BS
814if( @path_h ){
815 foreach my $path_h (@path_h) {
a0d0e21e
LW
816 my($h) = $path_h;
817 $h =~ s#^/usr/include/##;
ead2a595 818 if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
a887ff11
BS
819 print XS qq{#include <$h>\n};
820 }
821 print XS "\n";
a0d0e21e
LW
822}
823
ddf6bed1
IZ
824my %pointer_typedefs;
825my %struct_typedefs;
826
827sub td_is_pointer {
828 my $type = shift;
829 my $out = $pointer_typedefs{$type};
830 return $out if defined $out;
831 my $otype = $type;
832 $out = ($type =~ /\*$/);
833 # This converts only the guys which do not have trailing part in the typedef
834 if (not $out
835 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
836 $type = normalize_type($type);
837 print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
838 if $opt_d;
839 $out = td_is_pointer($type);
840 }
841 return ($pointer_typedefs{$otype} = $out);
842}
843
844sub td_is_struct {
845 my $type = shift;
846 my $out = $struct_typedefs{$type};
847 return $out if defined $out;
848 my $otype = $type;
849 $out = ($type =~ /^struct\b/) && !td_is_pointer($type);
850 # This converts only the guys which do not have trailing part in the typedef
851 if (not $out
852 and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
853 $type = normalize_type($type);
854 print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
855 if $opt_d;
856 $out = td_is_struct($type);
857 }
858 return ($struct_typedefs{$otype} = $out);
859}
860
861# Some macros will bomb if you try to return them from a double-returning func.
862# Say, ((char *)0), or strlen (if somebody #define STRLEN strlen).
863# Fortunately, we can detect both these cases...
864sub protect_convert_to_double {
865 my $in = shift;
866 my $val;
867 return '' unless defined ($val = $seen_define{$in});
868 return '(IV)' if $known_fnames{$val};
869 # OUT_t of ((OUT_t)-1):
870 return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/;
871 td_is_pointer($2) ? '(IV)' : '';
a0d0e21e
LW
872}
873
ddf6bed1
IZ
874# For each of the generated functions, length($pref) leading
875# letters are already checked. Moreover, it is recommended that
876# the generated functions uses switch on letter at offset at least
877# $off + length($pref).
878#
879# The given list has length($pref) chars removed at front, it is
880# guarantied that $off leading chars in the rest are the same for all
881# elts of the list.
882#
883# Returns: how at which offset it was decided to make a switch, or -1 if none.
884
885sub write_const;
886
887sub write_const {
888 my ($fh, $pref, $off, $list) = (shift,shift,shift,shift);
889 my %leading;
890 my $offarg = length $pref;
891
892 if (@$list == 0) { # Can happen on the initial iteration only
893 print $fh <<"END";
a0d0e21e 894static double
d94c7266 895constant(char *name, int arg)
a0d0e21e 896{
ddf6bed1
IZ
897 errno = EINVAL;
898 return 0;
899}
a0d0e21e 900END
ddf6bed1
IZ
901 return -1;
902 }
a0d0e21e 903
ddf6bed1
IZ
904 if (@$list == 1) { # Can happen on the initial iteration only
905 my $protect = protect_convert_to_double("$pref$list->[0]");
e1666bf5 906
ddf6bed1
IZ
907 print $fh <<"END";
908static double
909constant(char *name, int arg)
910{
911 if (strEQ(name + $offarg, "$list->[0]")) { /* $pref removed */
912#ifdef $pref$list->[0]
913 return $protect$pref$list->[0];
914#else
915 errno = ENOENT;
916 return 0;
917#endif
918 }
919 errno = EINVAL;
920 return 0;
e1666bf5 921}
ddf6bed1
IZ
922END
923 return -1;
924 }
e1666bf5 925
ddf6bed1
IZ
926 for my $n (@$list) {
927 my $c = substr $n, $off, 1;
928 $leading{$c} = [] unless exists $leading{$c};
929 push @{$leading{$c}}, substr $n, $off + 1;
930 }
931
932 if (keys(%leading) == 1) {
933 return 1 + write_const $fh, $pref, $off + 1, $list;
934 }
935
936 my $leader = substr $list->[0], 0, $off;
937 foreach $letter (keys %leading) {
938 write_const $fh, "$pref$leader$letter", 0, $leading{$letter}
939 if @{$leading{$letter}} > 1;
940 }
a0d0e21e 941
ddf6bed1
IZ
942 my $npref = "_$pref";
943 $npref = '' if $pref eq '';
a0d0e21e 944
ddf6bed1
IZ
945 print $fh <<"END";
946static double
947constant$npref(char *name, int arg)
948{
949 errno = 0;
950 switch (name[$offarg + $off]) {
951END
952
953 foreach $letter (sort keys %leading) {
954 my $let = $letter;
955 $let = '\0' if $letter eq '';
956
957 print $fh <<EOP;
958 case '$let':
959EOP
960 if (@{$leading{$letter}} > 1) {
961 # It makes sense to call a function
962 if ($off) {
963 print $fh <<EOP;
964 if (!strnEQ(name + $offarg,"$leader", $off))
965 break;
966EOP
967 }
968 print $fh <<EOP;
969 return constant_$pref$leader$letter(name, arg);
970EOP
971 } else {
972 # Do it ourselves
973 my $protect
974 = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]");
975
976 print $fh <<EOP;
977 if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) { /* $pref removed */
978#ifdef $pref$leader$letter$leading{$letter}[0]
979 return $protect$pref$leader$letter$leading{$letter}[0];
a0d0e21e
LW
980#else
981 goto not_there;
982#endif
ddf6bed1
IZ
983 }
984EOP
a0d0e21e 985 }
ddf6bed1
IZ
986 }
987 print $fh <<"END";
a0d0e21e
LW
988 }
989 errno = EINVAL;
990 return 0;
991
992not_there:
993 errno = ENOENT;
994 return 0;
995}
996
e1666bf5 997END
ddf6bed1
IZ
998
999}
1000
1001if( ! $opt_c ) {
1002 print XS <<"END";
1003static int
1004not_here(char *s)
1005{
1006 croak("$module::%s not implemented on this architecture", s);
1007 return -1;
1008}
1009
1010END
1011
1012 write_const(\*XS, '', 0, \@const_names);
e1666bf5
TB
1013}
1014
ead2a595 1015$prefix = "PREFIX = $opt_p" if defined $opt_p;
e1666bf5
TB
1016# Now switch from C to XS by issuing the first MODULE declaration:
1017print XS <<"END";
a0d0e21e 1018
ead2a595 1019MODULE = $module PACKAGE = $module $prefix
1020
1021END
1022
1023foreach (sort keys %const_xsub) {
1024 print XS <<"END";
1025char *
1026$_()
1027
1028 CODE:
1029#ifdef $_
1030 RETVAL = $_;
1031#else
1032 croak("Your vendor has not defined the $module macro $_");
1033#endif
1034
1035 OUTPUT:
1036 RETVAL
a0d0e21e 1037
e1666bf5 1038END
ead2a595 1039}
e1666bf5
TB
1040
1041# If a constant() function was written then output a corresponding
1042# XS declaration:
1043print XS <<"END" unless $opt_c;
1044
a0d0e21e
LW
1045double
1046constant(name,arg)
1047 char * name
1048 int arg
1049
1050END
a0d0e21e 1051
5273d82d 1052my %seen_decl;
ddf6bed1 1053my %typemap;
5273d82d 1054
ead2a595 1055sub print_decl {
1056 my $fh = shift;
1057 my $decl = shift;
1058 my ($type, $name, $args) = @$decl;
5273d82d
IZ
1059 return if $seen_decl{$name}++; # Need to do the same for docs as well?
1060
ead2a595 1061 my @argnames = map {$_->[1]} @$args;
ddf6bed1 1062 my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
5273d82d 1063 my @argarrays = map { $_->[4] || '' } @$args;
ead2a595 1064 my $numargs = @$args;
1065 if ($numargs and $argtypes[-1] eq '...') {
1066 $numargs--;
1067 $argnames[-1] = '...';
1068 }
1069 local $" = ', ';
ddf6bed1
IZ
1070 $type = normalize_type($type, 1);
1071
ead2a595 1072 print $fh <<"EOP";
1073
1074$type
1075$name(@argnames)
1076EOP
1077
1078 for $arg (0 .. $numargs - 1) {
1079 print $fh <<"EOP";
5273d82d 1080 $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
ead2a595 1081EOP
1082 }
1083}
1084
5273d82d
IZ
1085# Should be called before any actual call to normalize_type().
1086sub get_typemap {
1087 # We do not want to read ./typemap by obvios reasons.
1088 my @tm = qw(../../../typemap ../../typemap ../typemap);
1089 my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap";
1090 unshift @tm, $stdtypemap;
1091 my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
1092 my $image;
ddf6bed1
IZ
1093
1094 # Start with useful default values
1095 $typemap{float} = 'T_DOUBLE';
1096
5273d82d
IZ
1097 foreach $typemap (@tm) {
1098 next unless -e $typemap ;
1099 # skip directories, binary files etc.
1100 warn " Scanning $typemap\n";
1101 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
1102 unless -T $typemap ;
1103 open(TYPEMAP, $typemap)
1104 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
1105 my $mode = 'Typemap';
1106 while (<TYPEMAP>) {
1107 next if /^\s*\#/;
1108 if (/^INPUT\s*$/) { $mode = 'Input'; next; }
1109 elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; }
1110 elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
1111 elsif ($mode eq 'Typemap') {
1112 next if /^\s*($|\#)/ ;
ddf6bed1 1113 if ( ($type, $image) =
5273d82d
IZ
1114 /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
1115 # This may reference undefined functions:
1116 and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
ddf6bed1 1117 $typemap{normalize_type($type)} = $image;
5273d82d
IZ
1118 }
1119 }
1120 }
1121 close(TYPEMAP) or die "Cannot close $typemap: $!";
1122 }
1123 %std_types = %types_seen;
1124 %types_seen = ();
1125}
1126
ead2a595 1127
ddf6bed1 1128sub normalize_type { # Second arg: do not strip const's before \*
ead2a595 1129 my $type = shift;
ddf6bed1
IZ
1130 # XXXX function-pointer declarations?
1131 my $keep_deep_const = shift() ? '\b(?![^(,)]*\*)' : '';
1132 my $ignore_mods
1133 = "(?:\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\b\s*)*";
ead2a595 1134 $type =~ s/$ignore_mods//go;
ddf6bed1 1135 $type =~ s/([^\s\w])/ \1 /g;
ead2a595 1136 $type =~ s/\s+$//;
1137 $type =~ s/^\s+//;
ddf6bed1
IZ
1138 $type =~ s/\s+/ /g;
1139 $type =~ s/\* (?=\*)/*/g;
1140 $type =~ s/\. \. \./.../g;
1141 $type =~ s/ ,/,/g;
5273d82d
IZ
1142 $types_seen{$type}++
1143 unless $type eq '...' or $type eq 'void' or $std_types{$type};
ead2a595 1144 $type;
1145}
1146
ddf6bed1
IZ
1147my $need_opaque;
1148
1149sub assign_typemap_entry {
1150 my $type = shift;
1151 my $otype = $type;
1152 my $entry;
1153 if ($tmask and $type =~ /$tmask/) {
1154 print "Type $type matches -o mask\n" if $opt_d;
1155 $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1156 }
1157 elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
1158 $type = normalize_type $type;
1159 print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
1160 $entry = assign_typemap_entry($type);
1161 }
1162 $entry ||= $typemap{$otype}
1163 || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
1164 $typemap{$otype} = $entry;
1165 $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
1166 return $entry;
1167}
1168
ead2a595 1169if ($opt_x) {
5273d82d 1170 for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
ead2a595 1171}
1172
a0d0e21e 1173close XS;
5273d82d
IZ
1174
1175if (%types_seen) {
1176 my $type;
1177 warn "Writing $ext$modpname/typemap\n";
1178 open TM, ">typemap" or die "Cannot open typemap file for write: $!";
1179
1180 for $type (keys %types_seen) {
ddf6bed1
IZ
1181 my $entry = assign_typemap_entry $type;
1182 print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
5273d82d
IZ
1183 }
1184
ddf6bed1
IZ
1185 print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
1186#############################################################################
1187INPUT
1188T_OPAQUE_STRUCT
1189 if (sv_derived_from($arg, \"${ntype}\")) {
1190 STRLEN len;
1191 char *s = SvPV((SV*)SvRV($arg), len);
1192
1193 if (len != sizeof($var))
1194 croak(\"Size %d of packed data != expected %d\",
1195 len, sizeof($var));
1196 $var = *($type *)s;
1197 }
1198 else
1199 croak(\"$var is not of type ${ntype}\")
1200#############################################################################
1201OUTPUT
1202T_OPAQUE_STRUCT
1203 sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
1204EOP
1205
5273d82d
IZ
1206 close TM or die "Cannot close typemap file for write: $!";
1207}
1208
2920c5d2 1209} # if( ! $opt_X )
e1666bf5 1210
8e07c86e
AD
1211warn "Writing $ext$modpname/Makefile.PL\n";
1212open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
a0d0e21e 1213
a0d0e21e
LW
1214print PL <<'END';
1215use ExtUtils::MakeMaker;
1216# See lib/ExtUtils/MakeMaker.pm for details of how to influence
42793c05 1217# the contents of the Makefile that is written.
a0d0e21e 1218END
42793c05
TB
1219print PL "WriteMakefile(\n";
1220print PL " 'NAME' => '$module',\n";
c07a80fd 1221print PL " 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n";
2920c5d2 1222if( ! $opt_X ){ # print C stuff, unless XS is disabled
ddf6bed1 1223 $opt_F = '' unless defined $opt_F;
2920c5d2 1224 print PL " 'LIBS' => ['$extralibs'], # e.g., '-lm' \n";
ddf6bed1 1225 print PL " 'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING' \n";
2920c5d2 1226 print PL " 'INC' => '', # e.g., '-I/usr/include/other' \n";
1227}
a0d0e21e 1228print PL ");\n";
f508c652 1229close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
1230
1231warn "Writing $ext$modpname/test.pl\n";
1232open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
1233print EX <<'_END_';
1234# Before `make install' is performed this script should be runnable with
1235# `make test'. After `make install' it should work as `perl test.pl'
1236
1237######################### We start with some black magic to print on failure.
1238
1239# Change 1..1 below to 1..last_test_to_print .
1240# (It may become useful if the test is moved to ./t subdirectory.)
1241
5ae7f1db 1242BEGIN { $| = 1; print "1..1\n"; }
f508c652 1243END {print "not ok 1\n" unless $loaded;}
1244_END_
1245print EX <<_END_;
1246use $module;
1247_END_
1248print EX <<'_END_';
1249$loaded = 1;
1250print "ok 1\n";
1251
1252######################### End of black magic.
1253
1254# Insert your test code below (better if it prints "ok 13"
1255# (correspondingly "not ok 13") depending on the success of chunk 13
1256# of the test code):
e1666bf5 1257
f508c652 1258_END_
1259close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
a0d0e21e 1260
c0f8b9cd 1261unless ($opt_C) {
ddf6bed1
IZ
1262 warn "Writing $ext$modpname/Changes\n";
1263 $" = ' ';
1264 open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
1265 @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
1266 print EX <<EOP;
1267Revision history for Perl extension $module.
1268
1269$TEMPLATE_VERSION @{[scalar localtime]}
1270\t- original version; created by h2xs $H2XS_VERSION with options
1271\t\t@ARGS
1272
1273EOP
1274 close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
c0f8b9cd 1275}
c07a80fd 1276
1277warn "Writing $ext$modpname/MANIFEST\n";
5ae7f1db 1278open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
1279@files = <*>;
1280if (!@files) {
1281 eval {opendir(D,'.');};
1282 unless ($@) { @files = readdir(D); closedir(D); }
1283}
1284if (!@files) { @files = map {chomp && $_} `ls`; }
55497cff 1285if ($^O eq 'VMS') {
1286 foreach (@files) {
1287 # Clip trailing '.' for portability -- non-VMS OSs don't expect it
1288 s%\.$%%;
1289 # Fix up for case-sensitive file systems
1290 s/$modfname/$modfname/i && next;
1291 $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
bbce6d69 1292 $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
55497cff 1293 }
1294}
3e3baf6d 1295print MANI join("\n",@files), "\n";
5ae7f1db 1296close MANI;
40000a8c 1297!NO!SUBS!
4633a7c4
LW
1298
1299close OUT or die "Can't close $file: $!";
1300chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1301exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1 1302chdir $origdir;