This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Refactor xsinit generation code in ExtUtils::Embed.
[perl5.git] / lib / ExtUtils / Embed.pm
index d244e48..71c3876 100644 (file)
@@ -1,16 +1,7 @@
-# $Id: Embed.pm,v 1.2501 $
-require 5.002;
-
 package ExtUtils::Embed;
 require Exporter;
-require FileHandle;
 use Config;
-use Getopt::Std;
-use File::Spec;
-
-#Only when we need them
-#require ExtUtils::MakeMaker;
-#require ExtUtils::Liblist;
+require File::Spec;
 
 use vars qw(@ISA @EXPORT $VERSION
            @Extensions $Verbose $lib_ext
@@ -18,17 +9,14 @@ use vars qw(@ISA @EXPORT $VERSION
            );
 use strict;
 
-$VERSION = sprintf("%d.%02d", q$Revision: 1.2506 $ =~ /(\d+)\.(\d+)/);
+# This is not a dual-life module, so no need for development version numbers
+$VERSION = '1.31';
 
 @ISA = qw(Exporter);
 @EXPORT = qw(&xsinit &ldopts 
             &ccopts &ccflags &ccdlflags &perl_inc
             &xsi_header &xsi_protos &xsi_body);
 
-#let's have Miniperl borrow from us instead
-#require ExtUtils::Miniperl;
-#*canon = \&ExtUtils::Miniperl::canon;
-
 $Verbose = 0;
 $lib_ext = $Config{lib_ext} || '.a';
 
@@ -44,21 +32,18 @@ sub my_return {
     }
 }
 
-sub is_perl_object {
-    $Config{ccflags} =~ /-DPERL_OBJECT/;  
-}
-
 sub xsinit { 
     my($file, $std, $mods) = @_;
     my($fh,@mods,%seen);
     $file ||= "perlxsi.c";
-    my $xsinit_proto = "pTHXo";
+    my $xsinit_proto = "pTHX";
 
     if (@_) {
        @mods = @$mods if $mods;
     }
     else {
-       getopts('o:s:');
+       require Getopt::Std;
+       Getopt::Std::getopts('o:s:');
        $file = $opt_o if defined $opt_o;
        $std  = $opt_s  if defined $opt_s;
        @mods = @ARGV;
@@ -69,14 +54,15 @@ sub xsinit {
        $fh = \*STDOUT;
     }
     else {
-       $fh = new FileHandle "> $file";
+        open $fh, '>', $file
+            or die "Can't open '$file': $!";
     }
 
     push(@mods, static_ext()) if defined $std;
     @mods = grep(!$seen{$_}++, @mods);
 
     print $fh &xsi_header();
-    print $fh "EXTERN_C void xs_init ($xsinit_proto);\n\n";     
+    print $fh "\nEXTERN_C void xs_init ($xsinit_proto);\n\n";
     print $fh &xsi_protos(@mods);
 
     print $fh "\nEXTERN_C void\nxs_init($xsinit_proto)\n{\n";
@@ -87,22 +73,17 @@ sub xsinit {
 
 sub xsi_header {
     return <<EOF;
-#include <EXTERN.h>
-#include <perl.h>
-
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
 EOF
 }    
 
 sub xsi_protos {
     my(@exts) = @_;
     my(@retval,%seen);
-    my $boot_proto = "pTHXo_ CV* cv";
-    foreach $_ (@exts){
-        my($pname) = canon('/', $_);
-        my($mname, $cname);
-        ($mname = $pname) =~ s!/!::!g;
-        ($cname = $pname) =~ s!/!__!g;
-       my($ccode) = "EXTERN_C void boot_${cname} ($boot_proto);\n";
+    foreach my $cname (canon('__', @exts)) {
+        my($ccode) = "EXTERN_C void boot_${cname} (pTHX_ CV* cv);\n";
        next if $seen{$ccode}++;
         push(@retval, $ccode);
     }
@@ -111,24 +92,25 @@ sub xsi_protos {
 
 sub xsi_body {
     my(@exts) = @_;
-    my($pname,@retval,%seen);
-    my($dl) = canon('/','DynaLoader');
-    push(@retval, "\tchar *file = __FILE__;\n");
-    push(@retval, "\tdXSUB_SYS;\n") if $] > 5.002;
-    push(@retval, "\n");
-
-    foreach $_ (@exts){
-        my($pname) = canon('/', $_);
-        my($mname, $cname, $ccode);
+    my(@retval,%seen);
+    push(@retval, "    static const char file[] = __FILE__;\n")
+        if @exts;
+    push(@retval, "    dXSUB_SYS;\n");
+    push(@retval, "    PERL_UNUSED_CONTEXT;\n");
+    push(@retval, "\n")
+        if @exts;
+
+    foreach my $pname (canon('/', @exts)) {
+        my($cname, $mname, $ccode);
         ($mname = $pname) =~ s!/!::!g;
         ($cname = $pname) =~ s!/!__!g;
-        if ($pname eq $dl){
+        if ($pname eq 'DynaLoader'){
             # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
             # boot_DynaLoader is called directly in DynaLoader.pm
-            $ccode = "\t/* DynaLoader is a special case */\n\tnewXS(\"${mname}::boot_${cname}\", boot_${cname}, file);\n";
+            $ccode = "    /* DynaLoader is a special case */\n    newXS(\"${mname}::boot_${cname}\", boot_${cname}, file);\n";
             push(@retval, $ccode) unless $seen{$ccode}++;
         } else {
-            $ccode = "\tnewXS(\"${mname}::bootstrap\", boot_${cname}, file);\n";
+            $ccode = "    newXS(\"${mname}::bootstrap\", boot_${cname}, file);\n";
             push(@retval, $ccode) unless $seen{$ccode}++;
         }
     }
@@ -136,13 +118,35 @@ sub xsi_body {
 }
 
 sub static_ext {
-    unless (scalar @Extensions) {
-       @Extensions = sort split /\s+/, $Config{static_ext};
-       unshift @Extensions, qw(DynaLoader);
-    }
+    @Extensions = ('DynaLoader', sort $Config{static_ext} =~ /(\S+)/g)
+        unless @Extensions;
     @Extensions;
 }
 
+sub _escape {
+    my $arg = shift;
+    return $$arg if $^O eq 'VMS'; # parens legal in qualifier lists
+    $$arg =~ s/([\(\)])/\\$1/g;
+}
+
+sub _ldflags {
+    my $ldflags = $Config{ldflags};
+    _escape(\$ldflags);
+    return $ldflags;
+}
+
+sub _ccflags {
+    my $ccflags = $Config{ccflags};
+    _escape(\$ccflags);
+    return $ccflags;
+}
+
+sub _ccdlflags {
+    my $ccdlflags = $Config{ccdlflags};
+    _escape(\$ccdlflags);
+    return $ccdlflags;
+}
+
 sub ldopts {
     require ExtUtils::MakeMaker;
     require ExtUtils::Liblist;
@@ -150,7 +154,6 @@ sub ldopts {
     my(@mods,@link_args,@argv);
     my($dllib,$config_libs,@potential_libs,@path);
     local($") = ' ' unless $" eq ' ';
-    my $MM = bless {} => 'MY';
     if (scalar @_) {
        @link_args = @$link_args if $link_args;
        @mods = @$mods if $mods;
@@ -182,13 +185,13 @@ sub ldopts {
     foreach $mod (@mods) {
        @ns = split(/::|\/|\\/, $mod);
        $sub = $ns[-1];
-       $root = $MM->catdir(@ns);
+       $root = File::Spec->catdir(@ns);
        
        print STDERR "searching for '$sub${lib_ext}'\n" if $Verbose;
        foreach (@path) {
-           next unless -e ($archive = $MM->catdir($_,"auto",$root,"$sub$lib_ext"));
+           next unless -e ($archive = File::Spec->catdir($_,"auto",$root,"$sub$lib_ext"));
            push @archives, $archive;
-           if(-e ($extra = $MM->catdir($_,"auto",$root,"extralibs.ld"))) {
+           if(-e ($extra = File::Spec->catdir($_,"auto",$root,"extralibs.ld"))) {
                local(*FH); 
                if(open(FH, $extra)) {
                    my($libs) = <FH>; chomp $libs;
@@ -207,18 +210,25 @@ sub ldopts {
     if ($^O eq 'MSWin32') {
        $libperl = $Config{libperl};
     }
-    else {
-       $libperl = (grep(/^-l\w*perl\w*$/, @link_args))[0] || "-lperl";
+    elsif ($^O eq 'os390' && $Config{usedl}) {
+       # Nothing for OS/390 (z/OS) dynamic.
+    } else {
+       $libperl = (grep(/^-l\w*perl\w*$/, @link_args))[0]
+           || ($Config{libperl} =~ /^lib(\w+)(\Q$lib_ext\E|\.\Q$Config{dlext}\E)$/
+               ? "-l$1" : '')
+               || "-lperl";
     }
 
     my $lpath = File::Spec->catdir($Config{archlibexp}, 'CORE');
     $lpath = qq["$lpath"] if $^O eq 'MSWin32';
     my($extralibs, $bsloadlibs, $ldloadlibs, $ld_run_path) =
-       $MM->ext(join ' ', "-L$lpath", $libperl, @potential_libs);
+       MM->ext(join ' ', "-L$lpath", $libperl, @potential_libs);
 
     my $ld_or_bs = $bsloadlibs || $ldloadlibs;
     print STDERR "bs: $bsloadlibs ** ld: $ldloadlibs" if $Verbose;
-    my $linkage = "$Config{ccdlflags} $Config{ldflags} @archives $ld_or_bs";
+    my $ccdlflags = _ccdlflags();
+    my $ldflags   = _ldflags();
+    my $linkage = "$ccdlflags $ldflags @archives $ld_or_bs";
     print STDERR "ldopts: '$linkage'\n" if $Verbose;
 
     return $linkage if scalar @_;
@@ -226,11 +236,13 @@ sub ldopts {
 }
 
 sub ccflags {
-    my_return(" $Config{ccflags} ");
+    my $ccflags = _ccflags();
+    my_return(" $ccflags ");
 }
 
 sub ccdlflags {
-    my_return(" $Config{ccdlflags} ");
+    my $ccdlflags = _ccdlflags();
+    my_return(" $ccdlflags ");
 }
 
 sub perl_inc {
@@ -246,12 +258,16 @@ sub ccopts {
 sub canon {
     my($as, @ext) = @_;
     foreach(@ext) {
-       # might be X::Y or lib/auto/X/Y/Y.a
-       next if s!::!/!g;
-       s:^(lib|ext)/(auto/)?::;
-       s:/\w+\.\w+$::;
+        # might be X::Y or lib/auto/X/Y/Y.a
+        next
+            if s!::!/!g;
+        s!^(?:lib|ext|dist|cpan)/(?:auto/)?!!;
+        s!/\w+\.\w+$!!;
+    }
+    if ($as ne '/') {
+        s!/!$as!
+            foreach @ext;
     }
-    grep(s:/:$as:, @ext) if ($as ne '/');
     @ext;
 }
 
@@ -400,7 +416,7 @@ rather than print it to STDOUT.
  perl -MExtUtils::Embed -e ldopts
 
 
-This will print arguments for linking with B<libperl.a>, B<DynaLoader> and 
+This will print arguments for linking with B<libperl> and
 extensions found in B<$Config{static_ext}>.  This includes libraries
 found in B<$Config{libs}> and the first ModuleName.a library
 for each extension that is found by searching B<@INC> or the path 
@@ -414,17 +430,8 @@ are picked up from the B<extralibs.ld> file in the same directory.
 
 This will do the same as the above example, along with printing additional arguments for linking with the B<Socket> extension.
 
-
- perl -MExtUtils::Embed -e ldopts -- DynaLoader
-
-
-This will print arguments for linking with just the B<DynaLoader> extension
-and B<libperl.a>.
-
-
  perl -MExtUtils::Embed -e ldopts -- -std Msql -- -L/usr/msql/lib -lmsql
 
-
 Any arguments after the second '--' token are additional linker
 arguments that will be examined for potential conflict.  If there is no
 conflict, the additional arguments will be part of the output.