From: Ævar Arnfjörð Bjarmason <avar@cpan.org>
Date: Thu, 15 Apr 2010 17:12:04 +0000 (+0000)
Subject: Set the legacy process name with prctl() on assignment to $0 on Linux
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7636ea95c5;p=p5sagit%2Fp5-mst-13.2.git

Set the legacy process name with prctl() on assignment to $0 on Linux

Ever since perl 4.000 we've only set the POSIX process name via
argv[0]. Unfortunately on Linux the POSIX name isn't used by utilities
like top(1), ps(1) and killall(1).

Now when we set C<$0 = "hello"> both C<qx[ps h $$]> (POSIX) and
C<qx[ps hc $$]> (legacy) will say "hello", instead of the latter being
"perl" as was previously the case.

See also the March 9 2010 thread "Why doesn't assignment to $0 on
Linux also call prctl()?" on perl5-porters.
---

diff --git a/handy.h b/handy.h
index ebe523f..1ff7fde 100644
--- a/handy.h
+++ b/handy.h
@@ -214,8 +214,7 @@ typedef U64TYPE U64;
  * GMTIME_MAX	GMTIME_MIN	LOCALTIME_MAX	LOCALTIME_MIN
  * HAS_CTIME64	HAS_LOCALTIME64	HAS_GMTIME64	HAS_DIFFTIME64
  * HAS_MKTIME64	HAS_ASCTIME64	HAS_GETADDRINFO	HAS_GETNAMEINFO
- * HAS_INETNTOP	HAS_INETPTON	CHARBITS	HAS_PRCTL_SET_NAME
- * HAS_PRCTL
+ * HAS_INETNTOP	HAS_INETPTON	CHARBITS	HAS_PRCTL
  * Not (yet) used at top level, but mention them for metaconfig
  */
 
diff --git a/mg.c b/mg.c
index 4a8d767..0341f6e 100644
--- a/mg.c
+++ b/mg.c
@@ -57,6 +57,10 @@ tie.
 #  include <sys/pstat.h>
 #endif
 
+#ifdef HAS_PRCTL_SET_NAME
+#  include <sys/prctl.h>
+#endif
+
 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
 #else
@@ -2823,6 +2827,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    PL_origargv[0][PL_origalen-1] = 0;
 	    for (i = 1; i < PL_origargc; i++)
 		PL_origargv[i] = 0;
+#ifdef HAS_PRCTL_SET_NAME
+	    /* Set the legacy process name in addition to the POSIX name on Linux */
+	    if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
+		/* diag_listed_as: SKIPME */
+		Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
+	    }
+#endif
 	}
 #endif
 	UNLOCK_DOLLARZERO_MUTEX;
diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index febf15f..0dd2e1e 100644
--- a/pod/perlvar.pod
+++ b/pod/perlvar.pod
@@ -1026,6 +1026,13 @@ have their own copies of it.
 If the program has been given to perl via the switches C<-e> or C<-E>,
 C<$0> will contain the string C<"-e">.
 
+On Linux as of perl 5.14 the legacy process name will be set with
+L<prctl(2)>, in addition to altering the POSIX name via C<argv[0]> as
+perl has done since version 4.000. Now system utilities that read the
+legacy process name such as ps, top and killall will recognize the
+name you set when assigning to C<$0>. The string you supply will be
+cut off at 16 bytes, this is a limitation imposed by Linux.
+
 =item $[
 X<$[>
 
diff --git a/t/op/magic.t b/t/op/magic.t
index ff58352..bef4922 100644
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -12,7 +12,7 @@ BEGIN {
 use warnings;
 use Config;
 
-plan (tests => 81);
+plan (tests => 83);
 
 $Is_MSWin32  = $^O eq 'MSWin32';
 $Is_NetWare  = $^O eq 'NetWare';
@@ -347,6 +347,37 @@ SKIP: {
 	}
 }
 
+# Check that assigning to $0 on Linux sets the process name with both
+# argv[0] assignment and by calling prctl()
+{
+  SKIP: {
+    skip "We don't have prctl() here", 2 unless $Config{d_prctl_set_name};
+
+    # We don't really need these tests. prctl() is tested in the
+    # Kernel, but test it anyway for our sanity. If something doesn't
+    # work (like if the system doesn't have a ps(1) for whatever
+    # reason) just bail out gracefully.
+    my $maybe_ps = sub {
+        my ($cmd) = @_;
+        local ($?, $!);
+
+        no warnings;
+        my $res = `$cmd`;
+        skip "Couldn't shell out to `$cmd', returned code $?", 2 if $?;
+        return $res;
+    };
+
+    my $name = "Good Morning, Dave";
+    $0 = $name;
+
+    chomp(my $argv0 = $maybe_ps->("ps h $$"));
+    chomp(my $prctl = $maybe_ps->("ps hc $$"));
+
+    like($argv0, $name, "Set process name through argv[0] ($argv0)");
+    like($prctl, substr($name, 0, 15), "Set process name through prctl() ($prctl)");
+  }
+}
+
 {
     my $ok = 1;
     my $warn = '';