develooper Front page | perl.perl5.porters | Postings from August 2002

Re: [PATCH] posixify getppid on linux-multithread

Thread Previous | Thread Next
From:
Rafael Garcia-Suarez
Date:
August 8, 2002 15:01
Subject:
Re: [PATCH] posixify getppid on linux-multithread
Message ID:
20020808235953.3efda157.rgarciasuarez@free.fr
Arthur Bergman wrote:
> I would store it in ${^PPID} rather than a global PL_ppid variable.

The same patch, implemented with ${^PPID} instead of PL_ppid.
Note that ${^PPID} is defined only on linux/ithreads.
Hugo, apply the one you prefer.

--- hints/linux.sh.orig	Wed Jun  5 21:31:47 2002
+++ hints/linux.sh	Thu Aug  8 23:14:39 2002
@@ -249,7 +249,7 @@
 cat > UU/usethreads.cbu <<'EOCBU'
 case "$usethreads" in
 $define|true|[yY]*)
-        ccflags="-D_REENTRANT -D_GNU_SOURCE $ccflags"
+        ccflags="-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS $ccflags"
         set `echo X "$libswanted "| sed -e 's/ c / pthread c /'`
         shift
         libswanted="$*"
--- pod/perlvar.pod.orig	Fri Jul 19 23:12:30 2002
+++ pod/perlvar.pod	Thu Aug  8 23:15:51 2002
@@ -769,6 +769,12 @@ =item $$
 consider this variable read-only, although it will be altered
 across fork() calls.  (Mnemonic: same as shells.)
 
+Note for Linux users: on Linux, the C functions C<getpid()> and
+C<getppid()> return different values from different threads. In order to
+be portable, this behavior is not reflected by C<$$>, whose value remains
+consistent across threads. If you want to call the underlying C<getpid()>,
+consider using C<Inline::C> or another way to call a C library function.
+
 =item $REAL_USER_ID
 
 =item $UID
--- pod/perlfunc.pod.orig	Sun Aug  4 13:42:08 2002
+++ pod/perlfunc.pod	Thu Aug  8 23:15:51 2002
@@ -1873,6 +1873,13 @@ =item getppid
 
 Returns the process id of the parent process.
 
+Note for Linux users: on Linux, the C functions C<getpid()> and
+C<getppid()> return different values from different threads. In order to
+be portable, this behavior is not reflected by the perl-level function
+C<getppid()>, that returns a consistent value across threads. If you want
+to call the underlying C<getppid()>, consider using C<Inline::C> or
+another way to call a C library function.
+
 =item getpriority WHICH,WHO
 
 Returns the current priority for a process, a process group, or a user.
--- t/op/getpid.t.orig	Thu Aug  8 23:15:51 2002
+++ t/op/getpid.t	Thu Aug  8 23:43:17 2002
@@ -0,0 +1,37 @@
+#!perl -w
+
+# Tests if $$ and getppid return consistent values across threads
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(../lib);
+}
+
+use strict;
+use Config;
+
+BEGIN {
+    if (!$Config{useithreads}) {
+	print "1..0 # Skip: no ithreads\n";
+	exit;
+    }
+    if (!$Config{d_getppid}) {
+	print "1..0 # Skip: no getppid\n";
+	exit;
+    }
+}
+
+use threads;
+use threads::shared;
+
+my ($pid, $ppid) = ($$, getppid());
+my $pid2 : shared = 0;
+my $ppid2 : shared = 0;
+
+new threads( sub { ($pid2, $ppid2) = ($$, getppid()); } ) -> join();
+
+print "1..4\n";
+print "not " if $pid  != $pid2;     print "ok 1 - pids\n";
+print "not " if not defined $ppid;  print "ok 2 - ppid defined\n";
+print "not " if not defined $ppid2; print "ok 3 - ppid2 defined\n";
+print "not " if $ppid != $ppid2;    print "ok 4 - ppids\n";
--- MANIFEST.orig	Thu Aug  8 21:53:33 2002
+++ MANIFEST	Thu Aug  8 23:15:51 2002
@@ -2493,6 +2493,7 @@
 t/op/filetest.t			See if file tests work
 t/op/flip.t			See if range operator works
 t/op/fork.t			See if fork works
+t/op/getpid.t			See if $$ and getppid work with threads
 t/op/glob.t			See if <*> works
 t/op/gmagic.t			See if GMAGIC works
 t/op/goto.t			See if goto works
--- perl.c.orig	Tue Aug  6 21:17:07 2002
+++ perl.c	Thu Aug  8 23:19:11 2002
@@ -3651,6 +3651,13 @@ S_init_postdump_symbols(pTHX_ register i
 	sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
         SvREADONLY_on(GvSV(tmpgv));
     }
+#ifdef THREADS_HAVE_PIDS
+    if ((tmpgv = gv_fetchpv("\020PID", TRUE, SVt_PV))) {
+        SvREADONLY_off(GvSV(tmpgv));
+	sv_setiv(GvSV(tmpgv), (IV)getppid());
+        SvREADONLY_on(GvSV(tmpgv));
+    }
+#endif
 
     /* touch @F array to prevent spurious warnings 20020415 MJD */
     if (PL_minus_a) {
--- util.c.orig	Tue Aug  6 23:48:41 2002
+++ util.c	Thu Aug  8 23:19:28 2002
@@ -2155,10 +2155,17 @@ Perl_my_popen(pTHX_ char *cmd, char *mod
 #endif	/* defined OS2 */
 	/*SUPPRESS 560*/
 	if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
-        SvREADONLY_off(GvSV(tmpgv));
+	    SvREADONLY_off(GvSV(tmpgv));
 	    sv_setiv(GvSV(tmpgv), PerlProc_getpid());
-        SvREADONLY_on(GvSV(tmpgv));
-    }
+	    SvREADONLY_on(GvSV(tmpgv));
+	}
+#ifdef THREADS_HAVE_PIDS
+	if ((tmpgv = gv_fetchpv("\020PID", TRUE, SVt_PV))) {
+	    SvREADONLY_off(GvSV(tmpgv));
+	    sv_setiv(GvSV(tmpgv), (IV)getppid());
+	    SvREADONLY_on(GvSV(tmpgv));
+	}
+#endif
 	PL_forkprocess = 0;
 	hv_clear(PL_pidstatus);	/* we have no children */
 	return Nullfp;
--- pp_sys.c.orig	Sun Aug  4 21:02:35 2002
+++ pp_sys.c	Thu Aug  8 23:58:01 2002
@@ -3960,6 +3960,13 @@ PP(pp_fork)
 	    sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
             SvREADONLY_on(GvSV(tmpgv));
         }
+#ifdef THREADS_HAVE_PIDS
+	if ((tmpgv = gv_fetchpv("\020PID",TRUE, SVt_PV))) {
+	    SvREADONLY_off(GvSV(tmpgv));
+	    sv_setiv(GvSV(tmpgv), (IV)getppid());
+	    SvREADONLY_on(GvSV(tmpgv));
+	}
+#endif
 	hv_clear(PL_pidstatus);	/* no kids, so don't wait for 'em */
     }
     PUSHi(childpid);
@@ -4239,7 +4246,17 @@ PP(pp_getppid)
 {
 #ifdef HAS_GETPPID
     dSP; dTARGET;
+#ifdef THREADS_HAVE_PIDS
+    {
+	GV *tmpgv = gv_fetchpv("\020PID",TRUE, SVt_PV);
+	if (tmpgv)
+	    XPUSHi(SvIV(GvSV(tmpgv)));
+	else
+	    XPUSHi( 0 );
+    }
+#else
     XPUSHi( getppid() );
+#endif /* THREADS_HAVE_PIDS */
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "getppid");
End of Patch.

Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About