This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Mention sv_gets as the Perl-ish fgets-ish API.
[perl5.git] / t / porting / libperl.t
index 9c7c931..f62b80d 100644 (file)
@@ -3,7 +3,11 @@
 # Try opening libperl.a with nm, and verifying it has the kind of
 # symbols we expect, and no symbols we should avoid.
 #
-# Fail softly, expect things only on known platforms.
+# Fail softly, expect things only on known platforms:
+# - linux
+# - darwin (OS X), both x86 and ppc
+# - freebsd
+# and on other platforms, and if things seem odd, just give up (skip_all).
 #
 # Also, if the rarely-used builds options -DPERL_GLOBAL_STRUCT or
 # -DPERL_GLOBAL_STRUCT_PRIVATE are used, verify that they did what
@@ -12,7 +16,9 @@
 #
 # Debugging tip: nm output (this script's input) can be faked by
 # giving one command line argument for this script: it should be
-# either the filename to read, or "-" for STDIN.
+# either the filename to read, or "-" for STDIN.  You can also append
+# "@style" (where style is a supported nm style, like "gnu" or "darwin")
+# to this filename for "cross-parsing".
 #
 # Some terminology:
 # - "text" symbols are code
@@ -66,18 +72,60 @@ print "# libperl = $libperl_a\n";
 my $nm;
 my $nm_opt = '';
 my $nm_style;
+my $nm_fh;
+my $nm_err_tmp = "libperl$$";
+
+END {
+    # this is still executed when we skip_all above, avoid a warning
+    unlink $nm_err_tmp if $nm_err_tmp;
+}
+
+my $fake_input;
+my $fake_style;
+
+if (@ARGV == 1) {
+    $fake_input = shift @ARGV;
+    print "# Faking nm output from $fake_input\n";
+    if ($fake_input =~ s/\@(.+)$//) {
+        $fake_style = $1;
+        print "# Faking nm style from $fake_style\n";
+        if ($fake_style eq 'gnu' ||
+            $fake_style eq 'linux' ||
+            $fake_style eq 'freebsd') {
+            $nm_style = 'gnu'
+        } elsif ($fake_style eq 'darwin' || $fake_style eq 'osx') {
+            $nm_style = 'darwin'
+        } else {
+            die "$0: Unknown explicit nm style '$fake_style'\n";
+        }
+    }
+}
+
+unless (defined $nm_style) {
+    if ($^O eq 'linux') {
+        # The 'gnu' style could be equally well be called 'bsd' style,
+        # since the output format of the GNU binutils nm is really BSD.
+        $nm_style = 'gnu';
+    } elsif ($^O eq 'freebsd') {
+        $nm_style = 'gnu';
+    } elsif ($^O eq 'darwin') {
+        $nm_style = 'darwin';
+    }
+}
 
-if ($^O eq 'linux') {
-    $nm = '/usr/bin/nm';
-    $nm_style = 'gnu';
-} elsif ($^O eq 'darwin') {
-    $nm = '/usr/bin/nm';
-    $nm_style = 'darwin';
-    # With the -m option we get better information than the BSD-like
-    # default: with the default, a lot of symbols get dumped into 'S'
-    # or 's', for example one cannot tell the difference between const
-    # and non-const symbols.
-    $nm_opt = '-m';
+if (defined $nm_style) {
+    if ($nm_style eq 'gnu') {
+        $nm = '/usr/bin/nm';
+    } elsif ($nm_style eq 'darwin') {
+        $nm = '/usr/bin/nm';
+        # With the -m option we get better information than the BSD-like
+        # default: with the default, a lot of symbols get dumped into 'S'
+        # or 's', for example one cannot tell the difference between const
+        # and non-const data symbols.
+        $nm_opt = '-m';
+    } else {
+        die "$0: Unexpected nm style '$nm_style'\n";
+    }
 }
 
 unless (defined $nm) {
@@ -96,11 +144,11 @@ unless (-x $nm) {
     skip_all "no executable nm $nm";
 }
 
-if ($nm_style eq 'gnu') {
-    open(my $nm_fh, "$nm --version|") or
+if ($nm_style eq 'gnu' && !defined $fake_style) {
+    open(my $gnu_verify, "$nm --version|") or
         skip_all "nm failed: $!";
     my $gnu_verified;
-    while (<$nm_fh>) {
+    while (<$gnu_verify>) {
         if (/^GNU nm/) {
             $gnu_verified = 1;
             last;
@@ -111,24 +159,13 @@ if ($nm_style eq 'gnu') {
     }
 }
 
-my $nm_err_tmp = "libperl$$";
-
-END {
-    # this is still executed when we skip_all above, avoid a warning
-    unlink $nm_err_tmp if $nm_err_tmp;
-}
-
-my $nm_fh;
-
-if (@ARGV == 1) {
-    my $fake = shift @ARGV;
-    print "# Faking nm output from $fake\n";
-    if ($fake eq '-') {
+if (defined $fake_input) {
+    if ($fake_input eq '-') {
         open($nm_fh, "<&STDIN") or
             skip_all "Duping STDIN failed: $!";
     } else {
-        open($nm_fh, "<", $fake) or
-            skip_all "Opening '$fake' failed: $!";
+        open($nm_fh, "<", $fake_input) or
+            skip_all "Opening '$fake_input' failed: $!";
     }
     undef $nm_err_tmp; # In this case there will be no nm errors.
 } else {
@@ -140,6 +177,9 @@ sub is_perlish_symbol {
     $_[0] =~ /^(?:PL_|Perl|PerlIO)/;
 }
 
+# XXX Implement "internal test" for this script (option -t?)
+# to verify that the parsing does what it's intended to.
+
 sub nm_parse_gnu {
     my $symbols = shift;
     my $line = $_;
@@ -166,7 +206,7 @@ sub nm_parse_gnu {
                 # Bb: uninitialized data (bss)
                 # Ss: uninitialized data "for small objects"
                 $symbols->{data}{bss}{$1}{$symbols->{o}}++;
-            } elsif (/^0{16} D _LIB_VERSION$/) {
+            } elsif (/^D _LIB_VERSION$/) {
                 # Skip the _LIB_VERSION (not ours, probably libm)
             } elsif (/^[DdGg] (\w+)$/) {
                 # Dd: initialized data
@@ -372,24 +412,126 @@ if ($GSP) {
     ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars");
 }
 
+# See the comments in the beginning for what "undefined symbols"
+# really means.  We *should* have many of those, that is a good thing.
 ok(keys %{$symbols{undef}}, "has undefined symbols");
 
-my @good = qw(memchr memcmp memcpy chmod socket getenv sigaction sqrt time);
-if ($Config{usedl}) {
-    push @good, 'dlopen';
+# There are certain symbols we expect to see.
+
+# memchr, memcmp, memcpy should be used all over the place.
+#
+# chmod, socket, getenv, sigaction, sqrt, time are system/library
+# calls that should each see at least one use. sqrt can be sqrtl
+# if so configured.
+my %expected = (
+    memchr => 'd_memchr',
+    memcmp => 'd_memcmp',
+    memcpy => 'd_memcpy',
+    chmod  => undef, # There is no Configure symbol for chmod.
+    socket => 'd_socket',
+    getenv => undef, # There is no Configure symbol for getenv,
+    sigaction => 'd_sigaction',
+    time   => 'd_time',
+    );
+
+if ($Config{uselongdouble} && $Config{d_longdbl}) {
+    $expected{sqrtl} = 'd_sqrtl';
+} else {
+    $expected{sqrt} = undef; # There is no Configure symbol for sqrt.
+}
+
+# DynaLoader will use dlopen, unless we are building static,
+# and in the platforms we are supporting in this test.
+if ($Config{usedl} ) {
+    $expected{dlopen} = 'd_dlopen';
 }
-for my $good (@good) {
-    my @o = exists $symbols{undef}{$good} ?
-        sort keys %{ $symbols{undef}{$good} } : ();
-    ok(@o, "uses $good (@o)");
+
+for my $symbol (sort keys %expected) {
+    if (defined $expected{$symbol} && !$Config{$expected{$symbol}}) {
+      SKIP: {
+        skip("no $symbol");
+      }
+      next;
+    }
+    my @o = exists $symbols{undef}{$symbol} ?
+        sort keys %{ $symbols{undef}{$symbol} } : ();
+    # In some FreeBSD versions memcmp disappears (compiler inlining?).
+    if (($^O eq 'freebsd' ||
+         (defined $fake_style && $fake_style eq 'freebsd')) &&
+        $symbol eq 'memcmp' && @o == 0) {
+        SKIP: {
+            skip("freebsd memcmp");
+        }
+    } else {
+        ok(@o, "uses $symbol (@o)");
+    }
 }
 
-my @bad = qw(gets strcpy strcat strncpy strncat sprintf vsprintf);
-# XXX: add atoi() to @bad
-for my $bad (@bad) {
-    my @o = exists $symbols{undef}{$bad} ?
-        sort keys %{ $symbols{undef}{$bad} } : ();
-    is(@o, 0, "uses no $bad (@o)");
+# There are certain symbols we expect NOT to see.
+#
+# gets is horribly unsafe.
+#
+# fgets should not be used (Perl has its own API, sv_gets),
+# even without perlio.
+#
+# tmpfile is unsafe.
+#
+# strcat, strcpy, strncat, strncpy are unsafe.
+#
+# sprintf and vsprintf should not be used because
+# Perl has its own safer and more portable implementations.
+# (One exception: for certain floating point outputs
+# the native sprintf is still used in some platforms, see below.)
+#
+# atoi has unsafe and undefined failure modes, and is affected by locale.
+# Its cousins include atol and atoll.
+#
+# strtol and strtoul are affected by locale.
+# Cousins include strtoq.
+#
+# system should not be used, use pp_system or my_popen.
+#
+
+my %unexpected;
+
+for my $str (qw(system)) {
+    $unexpected{$str} = "d_$str";
+}
+
+for my $stdio (qw(gets fgets tmpfile sprintf vsprintf)) {
+    $unexpected{$stdio} = undef; # No Configure symbol for these.
+}
+for my $str (qw(strcat strcpy strncat strncpy)) {
+    $unexpected{$str} = undef; # No Configure symbol for these.
+}
+
+$unexpected{atoi} = undef; # No Configure symbol for atoi.
+$unexpected{atol} = undef; # No Configure symbol for atol.
+
+for my $str (qw(atoll strtol strtoul strtoq)) {
+    $unexpected{$str} = "d_$str";
+}
+
+for my $symbol (sort keys %unexpected) {
+    if (defined $unexpected{$symbol} && !$Config{$unexpected{$symbol}}) {
+      SKIP: {
+        skip("no $symbol");
+      }
+      next;
+    }
+    my @o = exists $symbols{undef}{$symbol} ?
+        sort keys %{ $symbols{undef}{$symbol} } : ();
+    # While sprintf() is bad in the general case,
+    # some platforms implement Gconvert via sprintf, in sv.o.
+    if ($symbol eq 'sprintf' &&
+        $Config{d_Gconvert} =~ /^sprintf/ &&
+        @o == 1 && $o[0] eq 'sv.o') {
+      SKIP: {
+        skip("uses sprintf for Gconvert in sv.o");
+      }
+    } else {
+        is(@o, 0, "uses no $symbol (@o)");
+    }
 }
 
 if (defined $nm_err_tmp) {