utils/h2xs.PL

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