better implementation of change#3326; open(local $foo,...) now

[p5sagit/p5-mst-13.2.git] / pp.c

diff --git a/pp.c b/pp.c
index 6b45946..f999b28 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -241,20 +241,25 @@ PP(pp_rv2gv)
                 * NI-S 1999/05/07
                 */ 
                if (PL_op->op_private & OPpDEREF) {
-                   GV *gv = (GV *) newSV(0);
-                   STRLEN len = 0;
-                   char *name = "";
-                   if (cUNOP->op_first->op_type == OP_PADSV) {
-                       SV *padname = *av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4);
-                       name = SvPV(padname,len);                                                    
+                   char *name;
+                   GV *gv;
+                   if (cUNOP->op_targ) {
+                       STRLEN len;
+                       SV *namesv = PL_curpad[cUNOP->op_targ];
+                       name = SvPV(namesv, len);
+                       gv = (GV*)NEWSV(0,len);
+                       gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
+                   }
+                   else {
+                       name = CopSTASHPV(PL_curcop);
+                       gv = newGVgen(name);
                    }
-                   gv_init(gv, PL_curcop->cop_stash, name, len, 0);
                    sv_upgrade(sv, SVt_RV);
-                   SvRV(sv) = (SV *) gv;
+                   SvRV(sv) = (SV*)gv;
                    SvROK_on(sv);
                    SvSETMAGIC(sv);
                    goto wasref;
-               }  
+               }
                if (PL_op->op_flags & OPf_REF ||
                    PL_op->op_private & HINT_STRICT_REFS)
                    DIE(aTHX_ PL_no_usym, "a symbol");
@@ -575,7 +580,7 @@ PP(pp_bless)
     HV *stash;
 
     if (MAXARG == 1)
-       stash = PL_curcop->cop_stash;
+       stash = CopSTASH(PL_curcop);
     else {
        SV *ssv = POPs;
        STRLEN len;
@@ -848,7 +853,7 @@ PP(pp_undef)
            Newz(602, gp, 1, GP);
            GvGP(sv) = gp_ref(gp);
            GvSV(sv) = NEWSV(72,0);
-           GvLINE(sv) = PL_curcop->cop_line;
+           GvLINE(sv) = CopLINE(PL_curcop);
            GvEGV(sv) = (GV*)sv;
            GvMULTI_on(sv);
        }
@@ -1783,7 +1788,7 @@ S_seed(pTHX)
     u = (U32)SEED_C1 * when;
 #  endif
 #endif
-    u += SEED_C3 * (U32)getpid();
+    u += SEED_C3 * (U32)PerlProc_getpid();
     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
     u += SEED_C5 * (U32)PTR2UV(&when);
@@ -3130,6 +3135,7 @@ PP(pp_reverse)
            *MARK++ = *SP;
            *SP-- = tmp;
        }
+       /* safe as long as stack cannot get extended in the above */
        SP = oldsp;
     }
     else {
@@ -3230,7 +3236,7 @@ PP(pp_unpack)
 {
     djSP;
     dPOPPOPssrl;
-    SV **oldsp = SP;
+    I32 start_sp_offset = SP - PL_stack_base;
     I32 gimme = GIMME_V;
     SV *sv;
     STRLEN llen;
@@ -3264,6 +3270,7 @@ PP(pp_unpack)
     register U32 culong;
     NV cdouble;
     int commas = 0;
+    int star;
 #ifdef PERL_NATINT_PACK
     int natint;                /* native integer */
     int unatint;       /* unsigned native integer */
@@ -3305,11 +3312,13 @@ PP(pp_unpack)
            else
                DIE(aTHX_ "'!' allowed only after types %s", natstr);
        }
+       star = 0;
        if (pat >= patend)
            len = 1;
        else if (*pat == '*') {
            len = strend - strbeg;      /* long enough */
            pat++;
+           star = 1;
        }
        else if (isDIGIT(*pat)) {
            len = *pat++ - '0';
@@ -3321,6 +3330,7 @@ PP(pp_unpack)
        }
        else
            len = (datumtype != '@');
+      redo_switch:
        switch(datumtype) {
        default:
            DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
@@ -3354,17 +3364,16 @@ PP(pp_unpack)
            s += len;
            break;
        case '/':
-           if (oldsp >= SP)
+           if (start_sp_offset >= SP - PL_stack_base)
                DIE(aTHX_ "/ must follow a numeric type");
-           if (*pat != 'a' && *pat != 'A' && *pat != 'Z')
-               DIE(aTHX_ "/ must be followed by a, A or Z");
            datumtype = *pat++;
            if (*pat == '*')
                pat++;          /* ignore '*' for compatibility with pack */
            if (isDIGIT(*pat))
                DIE(aTHX_ "/ cannot take a count" );
            len = POPi;
-           /* drop through */
+           star = 0;
+           goto redo_switch;
        case 'A':
        case 'Z':
        case 'a':
@@ -3395,7 +3404,7 @@ PP(pp_unpack)
            break;
        case 'B':
        case 'b':
-           if (pat[-1] == '*' || len > (strend - s) * 8)
+           if (star || len > (strend - s) * 8)
                len = (strend - s) * 8;
            if (checksum) {
                if (!PL_bitcount) {
@@ -3463,7 +3472,7 @@ PP(pp_unpack)
            break;
        case 'H':
        case 'h':
-           if (pat[-1] == '*' || len > (strend - s) * 2)
+           if (star || len > (strend - s) * 2)
                len = (strend - s) * 2;
            sv = NEWSV(35, len + 1);
            SvCUR_set(sv, len);
@@ -4195,7 +4204,7 @@ PP(pp_unpack)
            checksum = 0;
        }
     }
-    if (SP == oldsp && gimme == G_SCALAR)
+    if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
        PUSHs(&PL_sv_undef);
     RETURN;
 }
@@ -4427,10 +4436,16 @@ PP(pp_pack)
        case 'a':
            fromstr = NEXTFROM;
            aptr = SvPV(fromstr, fromlen);
-           if (pat[-1] == '*')
+           if (pat[-1] == '*') {
                len = fromlen;
-           if (fromlen > len)
+               if (datumtype == 'Z')
+                   ++len;
+           }
+           if (fromlen >= len) {
                sv_catpvn(cat, aptr, len);
+               if (datumtype == 'Z')
+                   *(SvEND(cat)-1) = '\0';
+           }
            else {
                sv_catpvn(cat, aptr, fromlen);
                len -= fromlen;
@@ -4828,7 +4843,7 @@ PP(pp_pack)
                sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
            }
            break;
-#endif /* HAS_QUAD */
+#endif
        case 'P':
            len = 1;            /* assume SV is correct length */
            /* FALL THROUGH */
@@ -4923,8 +4938,13 @@ PP(pp_split)
     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
             (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
 
-    if (pm->op_pmreplroot)
+    if (pm->op_pmreplroot) {
+#ifdef USE_ITHREADS
+       ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
+#else
        ary = GvAVn((GV*)pm->op_pmreplroot);
+#endif
+    }
     else if (gimme != G_ARRAY)
 #ifdef USE_THREADS
        ary = (AV*)PL_curpad[0];
@@ -5170,8 +5190,8 @@ Perl_unlock_condpair(pTHX_ void *svv)
        Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
     MgOWNER(mg) = 0;
     COND_SIGNAL(MgOWNERCONDP(mg));
-    DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%lx: unlock 0x%lx\n",
-                         (unsigned long)thr, (unsigned long)svv);)
+    DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
+                         PTR2UV(thr), PTR2UV(svv));)
     MUTEX_UNLOCK(MgMUTEXP(mg));
 }
 #endif /* USE_THREADS */
@@ -5195,10 +5215,10 @@ PP(pp_lock)
        while (MgOWNER(mg))
            COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
        MgOWNER(mg) = thr;
-       DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%lx: pp_lock lock 0x%lx\n",
-                             (unsigned long)thr, (unsigned long)sv);)
+       DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
+                             PTR2UV(thr), PTR2UV(sv));)
        MUTEX_UNLOCK(MgMUTEXP(mg));
-       SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
+       SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
     }
 #endif /* USE_THREADS */
     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV