posixify getppid on linux-multithread

Message-Id: <20020806215646.3f6852bb.rgarciasuarez@free.fr>

p4raw-id: //depot/perl@17798

11 files changed, 74 insertions, 4 deletions

diff --git a/MANIFEST b/MANIFEST
index da2347b50a..99539c6ecf 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2510,6 +2510,7 @@ t/op/fh.t			See if filehandles work
 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
diff --git a/embedvar.h b/embedvar.h
index 95e70b9960..d6a30fbfad 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -1375,6 +1375,7 @@
 #define PL_malloc_mutex		(PL_Vars.Gmalloc_mutex)
 #define PL_op_mutex		(PL_Vars.Gop_mutex)
 #define PL_patleave		(PL_Vars.Gpatleave)
+#define PL_ppid			(PL_Vars.Gppid)
 #define PL_runops_dbg		(PL_Vars.Grunops_dbg)
 #define PL_runops_std		(PL_Vars.Grunops_std)
 #define PL_sharehook		(PL_Vars.Gsharehook)
@@ -1393,6 +1394,7 @@
 #define PL_Gmalloc_mutex	PL_malloc_mutex
 #define PL_Gop_mutex		PL_op_mutex
 #define PL_Gpatleave		PL_patleave
+#define PL_Gppid		PL_ppid
 #define PL_Grunops_dbg		PL_runops_dbg
 #define PL_Grunops_std		PL_runops_std
 #define PL_Gsharehook		PL_sharehook
diff --git a/hints/linux.sh b/hints/linux.sh
index 7dccc1cc07..e152a6a3ce 100644
--- a/hints/linux.sh
+++ b/hints/linux.sh
@@ -249,7 +249,7 @@ esac
 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="$*"
diff --git a/perl.c b/perl.c
index 58e2ac1fd8..5aae0c88c7 100644
--- a/perl.c
+++ b/perl.c
@@ -3651,6 +3651,9 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
 	sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
         SvREADONLY_on(GvSV(tmpgv));
     }
+#ifdef THREADS_HAVE_PIDS
+    PL_ppid = (IV)getppid();
+#endif
 
     /* touch @F array to prevent spurious warnings 20020415 MJD */
     if (PL_minus_a) {
diff --git a/perlapi.h b/perlapi.h
index 693689f85a..0e0fef2f78 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -966,6 +966,8 @@ END_EXTERN_C
 #define PL_op_mutex		(*Perl_Gop_mutex_ptr(NULL))
 #undef  PL_patleave
 #define PL_patleave		(*Perl_Gpatleave_ptr(NULL))
+#undef  PL_ppid
+#define PL_ppid			(*Perl_Gppid_ptr(NULL))
 #undef  PL_runops_dbg
 #define PL_runops_dbg		(*Perl_Grunops_dbg_ptr(NULL))
 #undef  PL_runops_std
diff --git a/perlvars.h b/perlvars.h
index b841719dc2..6b26f0ed04 100644
--- a/perlvars.h
+++ b/perlvars.h
@@ -58,3 +58,7 @@ PERLVARI(Glockhook,	share_proc_t,	MEMBER_TO_FPTR(Perl_sv_nolocking))
 PERLVARI(Gunlockhook,	share_proc_t,	MEMBER_TO_FPTR(Perl_sv_nounlocking))
 PERLVARI(Gthreadhook,	thrhook_proc_t,	MEMBER_TO_FPTR(Perl_nothreadhook))
 
+/* Stores the PPID */
+#ifdef THREADS_HAVE_PIDS
+PERLVARI(Gppid,		IV,		0)
+#endif
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 90eeb97859..a489e7141e 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -1870,6 +1870,13 @@ does not accept a PID argument, so only C<PID==0> is truly portable.
 
 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.
diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index 7c0f5968fc..d90df1456c 100644
--- a/pod/perlvar.pod
+++ b/pod/perlvar.pod
@@ -769,6 +769,12 @@ The process number of the Perl running this script.  You should
 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
diff --git a/pp_sys.c b/pp_sys.c
index 7a44b6bb2e..54699c8841 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -3960,6 +3960,9 @@ PP(pp_fork)
 	    sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
             SvREADONLY_on(GvSV(tmpgv));
         }
+#ifdef THREADS_HAVE_PIDS
+	PL_ppid = (IV)getppid();
+#endif
 	hv_clear(PL_pidstatus);	/* no kids, so don't wait for 'em */
     }
     PUSHi(childpid);
@@ -4239,7 +4242,11 @@ PP(pp_getppid)
 {
 #ifdef HAS_GETPPID
     dSP; dTARGET;
+#   ifdef THREADS_HAVE_PIDS
+    XPUSHi( PL_ppid );
+#   else
     XPUSHi( getppid() );
+#   endif
     RETURN;
 #else
     DIE(aTHX_ PL_no_func, "getppid");
diff --git a/t/op/getpid.t b/t/op/getpid.t
new file mode 100644
index 0000000000..dd06f006a6
--- /dev/null
+++ b/t/op/getpid.t
@@ -0,0 +1,35 @@
+#!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..2\n";
+print "not " if $pid  != $pid2;  print "ok 1 - pids\n";
+print "not " if $ppid != $ppid2; print "ok 2 - ppids\n";
diff --git a/util.c b/util.c
index f275fcac00..35fb8a8c4d 100644
--- a/util.c
+++ b/util.c
@@ -2155,10 +2155,13 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 #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
+	PL_ppid = (IV)getppid();
+#endif
 	PL_forkprocess = 0;
 	hv_clear(PL_pidstatus);	/* we have no children */
 	return Nullfp;