develooper Front page | perl.perl5.porters | Postings from March 2011

[perl #85520] [patch] [resend] Turn $$ into a magical readonly variable that always fetches getpid() instead of caching it

Thread Next
From:
Max Maischein
Date:
March 7, 2011 01:38
Subject:
[perl #85520] [patch] [resend] Turn $$ into a magical readonly variable that always fetches getpid() instead of caching it
Message ID:
rt-3.6.HEAD-4136-1299435612-1377.85520-75-0@perl.org
# New Ticket Created by  Max Maischein 
# Please include the string:  [perl #85520]
# in the subject line of all future correspondence about this issue. 
# <URL: http://rt.perl.org/rt3/Ticket/Display.html?id=85520 >


This is a bug report for perl from corion@cpan.org,
generated with the help of perlbug 1.39 running under perl 5.13.10.


-----------------------------------------------------------------
[Please describe your issue here]


To get a Perlbug number, I'm resending the patch appended
to this mail.

commit df1cd6761ac9224f4aea7139509f9cacbf0b9ea0
Author: Max Maischein <corion@corion.net>
Date:   Wed Dec 29 16:35:08 2010 +0100

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

     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 4e79171..f11f0cc 100644
--- a/gv.c
+++ b/gv.c
@@ -1457,6 +1457,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, 
STRLEN full_len, I32 flags,
  #endif
  	    goto magicalize;

+	case '$':		/* $$ */
+	    goto magicalize;
  	case '!':		/* $! */
  	    GvMULTI_on(gv);
  	    /* If %! has been used, automatically load Errno.pm. */
diff --git a/mg.c b/mg.c
index 8053bf1..89c22c6 100644
--- a/mg.c
+++ b/mg.c
@@ -1115,6 +1115,12 @@ 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());
+	/* If you want another number, pull one at the entrance */
+	SvREADONLY_on(sv);
+	break;
+
      case '!':
  	{
  	dSAVE_ERRNO;
diff --git a/perl.c b/perl.c
index d2571a8..ab2e079 100644
--- a/perl.c
+++ b/perl.c
@@ -4125,11 +4125,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 2845266..c4998bb 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -4084,12 +4084,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 ac7dd57..b175c31 100644
--- a/util.c
+++ b/util.c
@@ -2770,12 +2770,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 70a2f65..8103ee7 100644
--- 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



[Please do not change anything below this line]
-----------------------------------------------------------------
---
Flags:
     category=core
     severity=low
---
Site configuration information for perl 5.13.10:

Configured by corion at Fri Mar  4 21:37:02 2011.

Summary of my perl5 (revision 5 version 13 subversion 10) configuration:
   Local Commit: de43a757c8705e286fca2f426d49cc107b810fd8
   Ancestor: 4d56cd4f546df82c1cabd288669bd8227d6847b4
   Platform:
     osname=MSWin32, osvers=5.1, archname=MSWin32-x86-multi-thread
     uname=''
     config_args='undef'
     hint=recommended, useposix=true, d_sigaction=undef
     useithreads=define, usemultiplicity=define
     useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
     use64bitint=undef, use64bitall=undef, uselongdouble=undef
     usemymalloc=n, bincompat5005=undef
   Compiler:
     cc='gcc', ccflags =' -s -O2 -DWIN32  -DPERL_IMPLICIT_CONTEXT 
-DPERL_IMPLICIT_SYS -fno-strict-aliasing -mms-bitfields',
     optimize='-s -O2',
     cppflags='-DWIN32'
     ccversion='', gccversion='4.4.3', gccosandvers=''
     intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
     d_longlong=undef, longlongsize=8, d_longdbl=define, longdblsize=12
     ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='long 
long', lseeksize=8
     alignbytes=8, prototype=define
   Linker and Libraries:
     ld='g++', ldflags ='-s -L"c:\perl\lib\CORE" -L"C:\MinGW\lib"'
     libpth=C:\MinGW\lib
     libs=-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 
-ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr 
-lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32
     perllibs=-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool 
-lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid 
-lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32
     libc=, so=dll, useshrplib=true, libperl=libperl513.a
     gnulibc_version=''
   Dynamic Linking:
     dlsrc=dl_win32.xs, dlext=dll, d_dlsymun=undef, ccdlflags=' '
     cccdlflags=' ', lddlflags='-mdll -s -L"c:\perl\lib\CORE" 
-L"C:\MinGW\lib"'

Locally applied patches:


---
@INC for perl 5.13.10:
     C:/Projekte/bleadperl-git/lib
     .

---
Environment for perl 5.13.10:
     HOME (unset)
     LANG (unset)
     LANGUAGE (unset)
     LD_LIBRARY_PATH (unset)
     LOGDIR (unset)
 
PATH=C:\strawberry\perl\bin;C:\strawberry\c\bin;C:\strawberry\perl\site\bin;C:\Programme\Microsoft 
IntelliType Pro\;C:\PROGRA~1\MATROX~1\System32;C:\Programme\MiKTeX 
2.7\miktex\bin;C:\WINDOWS\system32;C:\WINDOWS;C:\WINDOWS\System32\Wbem;C:\Programme\Haufe\iDesk\iDeskService\;C:\Programme\Git\cmd;C:\Programme\GNU\GnuPG\pub;C:\Programme\sK1 
Project\UniConvertor-1.1.5\;C:\Programme\sK1 
Project\UniConvertor-1.1.5\DLLs;C:\Programme\Gemeinsame Dateien\GTK\2.0\bin
     PERL_BADLANG (unset)
     SHELL (unset)


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