Turn $$ into a magical readonly variable that always fetches getpid() instead of...

The intent is that by not caching $$, we eliminate one opportunity for bugs:
If one embeds Perl or uses XS and calls fork(3) from C, Perls notion of $$
may go out of sync with what getpid() returns. By always fetching the
value of $$ via getpid(), this bug opportunity is eliminated. The overhead
of always fetching $$ should be small and is likely only used for tempfile
creation, which should be dwarfed by file system accesses.

diff --git a/gv.c b/gv.c
index 72cc9f6..a003adb 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1469,6 +1469,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 #endif
            goto magicalize;
 
+       case '$':               /* $$ */
+           SvREADONLY_on(GvSVn(gv));
+           goto magicalize;
        case '!':               /* $! */
            GvMULTI_on(gv);
            /* If %! has been used, automatically load Errno.pm. */

diff --git a/mg.c b/mg.c
index 85b5461..af2c647 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1114,6 +1114,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        if (PL_ors_sv)
            sv_copypv(sv, PL_ors_sv);
        break;
+    case '$': /* $$ */
+       sv_setiv(sv, (IV)PerlProc_getpid());
+       break;
+
     case '!':
        {
        dSAVE_ERRNO;

diff --git a/perl.c b/perl.c
index 4dc5bad..417b2fd 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -4155,11 +4155,6 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
 #endif /* !PERL_MICRO */
     }
     TAINT_NOT;
-    if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
-        SvREADONLY_off(GvSV(tmpgv));
-       sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
-        SvREADONLY_on(GvSV(tmpgv));
-    }
 #ifdef THREADS_HAVE_PIDS
     PL_ppid = (IV)getppid();
 #endif

diff --git a/pp_sys.c b/pp_sys.c
index 186465f..aa74cef 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -4017,12 +4017,6 @@ PP(pp_fork)
     if (childpid < 0)
        RETSETUNDEF;
     if (!childpid) {
-       GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
-       if (tmpgv) {
-            SvREADONLY_off(GvSV(tmpgv));
-           sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
-            SvREADONLY_on(GvSV(tmpgv));
-        }
 #ifdef THREADS_HAVE_PIDS
        PL_ppid = (IV)getppid();
 #endif

diff --git a/util.c b/util.c
index bd9010f..f6742e7 100644 (file)
--- a/util.c
+++ b/util.c
@@ -2759,12 +2759,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
       default, binary, low-level mode; see PerlIOBuf_open(). */
    PerlLIO_setmode((*mode == 'r'), O_BINARY);
 #endif 
-
-       if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
-           SvREADONLY_off(GvSV(tmpgv));
-           sv_setiv(GvSV(tmpgv), PerlProc_getpid());
-           SvREADONLY_on(GvSV(tmpgv));
-       }
 #ifdef THREADS_HAVE_PIDS
        PL_ppid = (IV)getppid();
 #endif

diff --git a/win32/perlhost.h b/win32/perlhost.h
index 0240044..abe7296 100644 (file)
--- a/win32/perlhost.h
+++ b/win32/perlhost.h
@@ -1722,18 +1722,11 @@ win32_start_child(LPVOID arg)
     PERL_SET_THX(my_perl);
     win32_checkTLS(my_perl);
 
-    /* set $$ to pseudo id */
 #ifdef PERL_SYNC_FORK
     w32_pseudo_id = id;
 #else
     w32_pseudo_id = GetCurrentThreadId();
 #endif
-    if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) {
-       SV *sv = GvSV(tmpgv);
-       SvREADONLY_off(sv);
-       sv_setiv(sv, -(IV)w32_pseudo_id);
-       SvREADONLY_on(sv);
-    }
 #ifdef PERL_USES_PL_PIDSTATUS    
     hv_clear(PL_pidstatus);
 #endif