tweaks for building with -DUSE_ITHREADS on !WIN32 platforms;

fix bug where lc($readonly) could result in bogus errors

p4raw-id: //depot/perl@4660

diff --git a/embed.h b/embed.h
index 9e331fb..a768cb6 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -49,6 +49,8 @@
 #else
 #endif
 #if defined(USE_ITHREADS)
+#  if defined(USE_IMPLICIT_SYS)
+#  endif
 #endif
 #if defined(MYMALLOC)
 #define malloced_size          Perl_malloced_size
@@ -1462,6 +1464,8 @@
 #else
 #endif
 #if defined(USE_ITHREADS)
+#  if defined(USE_IMPLICIT_SYS)
+#  endif
 #endif
 #if defined(MYMALLOC)
 #define malloced_size          Perl_malloced_size
@@ -2848,6 +2852,8 @@
 #else
 #endif
 #if defined(USE_ITHREADS)
+#  if defined(USE_IMPLICIT_SYS)
+#  endif
 #endif
 #if defined(MYMALLOC)
 #define malloc                 Perl_malloc

diff --git a/embed.pl b/embed.pl
index 978b13c..e545124 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1040,12 +1040,14 @@ jno     |int    |perl_parse     |PerlInterpreter* interp|XSINIT_t xsinit \
                                |int argc|char** argv|char** env
 #if defined(USE_ITHREADS)
 jno    |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags
+#  if defined(USE_IMPLICIT_SYS)
 jno    |PerlInterpreter*|perl_clone_using|PerlInterpreter *interp|UV flags \
                                |struct IPerlMem* m|struct IPerlMem* ms \
                                |struct IPerlMem* mp|struct IPerlEnv* e \
                                |struct IPerlStdIO* io|struct IPerlLIO* lio \
                                |struct IPerlDir* d|struct IPerlSock* s \
                                |struct IPerlProc* p
+#  endif
 #endif
 
 #if defined(MYMALLOC)

diff --git a/iperlsys.h b/iperlsys.h
index 222d88b..0d9f699 100644 (file)
--- a/iperlsys.h
+++ b/iperlsys.h
@@ -293,6 +293,7 @@ struct IPerlStdIOInfo
 
 #include "perlsdio.h"
 #include "perl.h"
+#define PerlIO_fdupopen(f)             (f)
 
 #endif /* PERL_IMPLICIT_SYS */
 

diff --git a/makedef.pl b/makedef.pl
index 4b1b84f..1d585a2 100644 (file)
--- a/makedef.pl
+++ b/makedef.pl
@@ -425,6 +425,7 @@ unless ($define{'PERL_IMPLICIT_CONTEXT'}) {
 unless ($define{'PERL_IMPLICIT_SYS'}) {
     skip_symbols [qw(
                    perl_alloc_using
+                   perl_clone_using
                    )];
 }
 
@@ -747,6 +748,8 @@ __DATA__
 # extra globals not included above.
 perl_alloc
 perl_alloc_using
+perl_clone
+perl_clone_using
 perl_construct
 perl_destruct
 perl_free

diff --git a/objXSUB.h b/objXSUB.h
index b28c69a..62d61b1 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -823,6 +823,8 @@
 #else
 #endif
 #if defined(USE_ITHREADS)
+#  if defined(USE_IMPLICIT_SYS)
+#  endif
 #endif
 #if defined(MYMALLOC)
 #endif

diff --git a/perlapi.c b/perlapi.c
index c5f91b4..7760255 100644 (file)
--- a/perlapi.c
+++ b/perlapi.c
@@ -43,6 +43,8 @@ START_EXTERN_C
 #else
 #endif
 #if defined(USE_ITHREADS)
+#  if defined(USE_IMPLICIT_SYS)
+#  endif
 #endif
 #if defined(MYMALLOC)
 #endif

diff --git a/pp.c b/pp.c
index f404883..c14a05c 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -2261,7 +2261,7 @@ PP(pp_ucfirst)
        
        tend = uv_to_utf8(tmpbuf, uv);
 
-       if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
+       if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
            dTARGET;
            sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
            sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
@@ -2273,7 +2273,7 @@ PP(pp_ucfirst)
        }
     }
     else {
-       if (!SvPADTMP(sv)) {
+       if (!SvPADTMP(sv) || SvREADONLY(sv)) {
            dTARGET;
            sv_setsv(TARG, sv);
            sv = TARG;
@@ -2318,7 +2318,7 @@ PP(pp_lcfirst)
        
        tend = uv_to_utf8(tmpbuf, uv);
 
-       if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
+       if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
            dTARGET;
            sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
            sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
@@ -2330,7 +2330,7 @@ PP(pp_lcfirst)
        }
     }
     else {
-       if (!SvPADTMP(sv)) {
+       if (!SvPADTMP(sv) || SvREADONLY(sv)) {
            dTARGET;
            sv_setsv(TARG, sv);
            sv = TARG;
@@ -2397,7 +2397,7 @@ PP(pp_uc)
        }
     }
     else {
-       if (!SvPADTMP(sv)) {
+       if (!SvPADTMP(sv) || SvREADONLY(sv)) {
            dTARGET;
            sv_setsv(TARG, sv);
            sv = TARG;
@@ -2468,7 +2468,7 @@ PP(pp_lc)
        }
     }
     else {
-       if (!SvPADTMP(sv)) {
+       if (!SvPADTMP(sv) || SvREADONLY(sv)) {
            dTARGET;
            sv_setsv(TARG, sv);
            sv = TARG;
@@ -4852,9 +4852,13 @@ PP(pp_pack)
                     * of pack() (and all copies of the result) are
                     * gone.
                     */
-                   if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
+                   if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr)
+                                               || (SvPADTMP(fromstr)
+                                                   && !SvREADONLY(fromstr))))
+                   {
                        Perl_warner(aTHX_ WARN_UNSAFE,
                                "Attempt to pack pointer to temporary value");
+                   }
                    if (SvPOK(fromstr) || SvNIOK(fromstr))
                        aptr = SvPV(fromstr,n_a);
                    else

diff --git a/pp_sys.c b/pp_sys.c
index 6599285..8a1c98c 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -3602,7 +3602,7 @@ PP(pp_fork)
     PUSHi(childpid);
     RETURN;
 #else
-#  if defined(USE_ITHREADS) && defined(WIN32)
+#  if defined(USE_ITHREADS) && defined(USE_IMPLICIT_SYS)
     djSP; dTARGET;
     Pid_t childpid;
 
@@ -3800,7 +3800,7 @@ PP(pp_exec)
 #endif
     }
 
-#ifdef USE_ITHREADS
+#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(USE_IMPLICIT_SYS)
     if (value >= 0)
        my_exit(value);
 #endif

diff --git a/proto.h b/proto.h
index 0225128..f057294 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -20,7 +20,9 @@ PERL_CALLCONV int     perl_run(PerlInterpreter* interp);
 PERL_CALLCONV int      perl_parse(PerlInterpreter* interp, XSINIT_t xsinit, int argc, char** argv, char** env);
 #if defined(USE_ITHREADS)
 PERL_CALLCONV PerlInterpreter* perl_clone(PerlInterpreter* interp, UV flags);
+#  if defined(USE_IMPLICIT_SYS)
 PERL_CALLCONV PerlInterpreter* perl_clone_using(PerlInterpreter *interp, UV flags, struct IPerlMem* m, struct IPerlMem* ms, struct IPerlMem* mp, struct IPerlEnv* e, struct IPerlStdIO* io, struct IPerlLIO* lio, struct IPerlDir* d, struct IPerlSock* s, struct IPerlProc* p);
+#  endif
 #endif
 
 #if defined(MYMALLOC)

diff --git a/sv.c b/sv.c
index 1eb7972..933151c 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -6526,13 +6526,23 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
 #endif
 
 PerlInterpreter *
-perl_clone(PerlInterpreter *my_perl, UV flags)
+perl_clone(PerlInterpreter *proto_perl, UV flags)
 {
 #ifdef PERL_OBJECT
-    CPerlObj *pPerl = (CPerlObj*)my_perl;
+    CPerlObj *pPerl = (CPerlObj*)proto_perl;
 #endif
-    return perl_clone_using(my_perl, flags, PL_Mem, PL_MemShared, PL_MemParse,
-                           PL_Env, PL_StdIO, PL_LIO, PL_Dir, PL_Sock, PL_Proc);
+
+#ifdef PERL_IMPLICIT_SYS
+    return perl_clone_using(proto_perl, flags,
+                           proto_perl->IMem,
+                           proto_perl->IMemShared,
+                           proto_perl->IMemParse,
+                           proto_perl->IEnv,
+                           proto_perl->IStdIO,
+                           proto_perl->ILIO,
+                           proto_perl->IDir,
+                           proto_perl->ISock,
+                           proto_perl->IProc);
 }
 
 PerlInterpreter *
@@ -6550,23 +6560,23 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     IV i;
     SV *sv;
     SV **svp;
-#ifdef PERL_OBJECT
+#  ifdef PERL_OBJECT
     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
                                        ipD, ipS, ipP);
     PERL_SET_INTERP(pPerl);
-#else
+#  else                /* !PERL_OBJECT */
     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
     PERL_SET_INTERP(my_perl);
 
-#  ifdef DEBUGGING
+#    ifdef DEBUGGING
     memset(my_perl, 0xab, sizeof(PerlInterpreter));
     PL_markstack = 0;
     PL_scopestack = 0;
     PL_savestack = 0;
     PL_retstack = 0;
-#  else
+#    else      /* !DEBUGGING */
     Zero(my_perl, 1, PerlInterpreter);
-#  endif
+#    endif     /* DEBUGGING */
 
     /* host pointers */
     PL_Mem             = ipM;
@@ -6578,7 +6588,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_Dir             = ipD;
     PL_Sock            = ipS;
     PL_Proc            = ipP;
-#endif
+#  endif       /* PERL_OBJECT */
+#else          /* !PERL_IMPLICIT_SYS */
+    IV i;
+    SV *sv;
+    SV **svp;
+    PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+#endif         /* PERL_IMPLICIT_SYS */
 
     /* arena roots */
     PL_xiv_arenaroot   = NULL;