Unicode data updated to be the latest beta of the Unicode 3.0.

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

diff --git a/pp_hot.c b/pp_hot.c
index f4ed171..38658d1 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -34,25 +34,7 @@
 /* Hot code. */
 
 #ifdef USE_THREADS
-STATIC void
-S_unset_cvowner(pTHX_ void *cvarg)
-{
-    register CV* cv = (CV *) cvarg;
-#ifdef DEBUGGING
-    dTHR;
-#endif /* DEBUGGING */
-
-    DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
-                          thr, cv, SvPEEK((SV*)cv))));
-    MUTEX_LOCK(CvMUTEXP(cv));
-    DEBUG_S(if (CvDEPTH(cv) != 0)
-               PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
-                             CvDEPTH(cv)););
-    assert(thr == CvOWNER(cv));
-    CvOWNER(cv) = 0;
-    MUTEX_UNLOCK(CvMUTEXP(cv));
-    SvREFCNT_dec(cv);
-}
+static void unset_cvowner(pTHXo_ void *cvarg);
 #endif /* USE_THREADS */
 
 PP(pp_const)
@@ -87,6 +69,12 @@ PP(pp_null)
     return NORMAL;
 }
 
+PP(pp_setstate)
+{
+    PL_curcop = (COP*)PL_op;
+    return NORMAL;
+}
+
 PP(pp_pushmark)
 {
     PUSHMARK(PL_stack_sp);
@@ -600,9 +588,15 @@ PP(pp_rv2hv)
        dTARGET;
        if (SvTYPE(hv) == SVt_PVAV)
            hv = avhv_keys((AV*)hv);
+#ifdef IV_IS_QUAD
        if (HvFILL(hv))
-           Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld",
-                     (long)HvFILL(hv), (long)HvMAX(hv) + 1);
+            Perl_sv_setpvf(aTHX_ TARG, "%" PERL_PRId64 "/%" PERL_PRId64,
+                      (Quad_t)HvFILL(hv), (Quad_t)HvMAX(hv) + 1);
+#else
+       if (HvFILL(hv))
+            Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld",
+                      (long)HvFILL(hv), (long)HvMAX(hv) + 1);
+#endif
        else
            sv_setiv(TARG, 0);
        
@@ -2142,7 +2136,7 @@ try_autoload:
            DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
                                  thr, sv);)
            MUTEX_UNLOCK(MgMUTEXP(mg));
-           save_destructor(Perl_unlock_condpair, sv);
+           SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
        }
        MUTEX_LOCK(CvMUTEXP(cv));
     }
@@ -2187,7 +2181,7 @@ try_autoload:
            CvOWNER(cv) = thr;
            SvREFCNT_inc(cv);
            if (CvDEPTH(cv) == 0)
-               SAVEDESTRUCTOR(S_unset_cvowner, (void*) cv);
+               SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
        }
        else {
            /* (2) => grab ownership of cv. (3) => make clone */
@@ -2224,7 +2218,7 @@ try_autoload:
            DEBUG_S(if (CvDEPTH(cv) != 0)
                        PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
                                      CvDEPTH(cv)););
-           SAVEDESTRUCTOR(S_unset_cvowner, (void*) cv);
+           SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
        }
     }
 #endif /* USE_THREADS */
@@ -2516,25 +2510,46 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
 PP(pp_method)
 {
     djSP;
+    SV* sv = TOPs;
+
+    if (SvROK(sv)) {
+       SV* rsv = SvRV(sv);
+       if (SvTYPE(rsv) == SVt_PVCV) {
+           SETs(rsv);
+           RETURN;
+       }
+    }
+
+    SETs(method_common(sv, Null(U32*)));
+    RETURN;
+}
+
+PP(pp_method_named)
+{
+    djSP;
+    SV* sv = cSVOP->op_sv;
+    U32 hash = SvUVX(sv);
+
+    XPUSHs(method_common(sv, &hash));
+    RETURN;
+}
+
+STATIC SV *
+S_method_common(pTHX_ SV* meth, U32* hashp)
+{
+    djSP;
     SV* sv;
     SV* ob;
     GV* gv;
     HV* stash;
     char* name;
+    STRLEN namelen;
     char* packname;
     STRLEN packlen;
 
-    if (SvROK(TOPs)) {
-       sv = SvRV(TOPs);
-       if (SvTYPE(sv) == SVt_PVCV) {
-           SETs(sv);
-           RETURN;
-       }
-    }
-
-    name = SvPV(TOPs, packlen);
+    name = SvPV(meth, namelen);
     sv = *(PL_stack_base + TOPMARK + 1);
-    
+
     if (SvGMAGICAL(sv))
         mg_get(sv);
     if (SvROK(sv))
@@ -2554,9 +2569,9 @@ PP(pp_method)
                    : !isIDFIRST(*packname)
                ))
            {
-               DIE(aTHX_ "Can't call method \"%s\" %s", name,
-                   SvOK(sv)? "without a package or object reference"
-                           : "on an undefined value");
+               Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
+                          SvOK(sv) ? "without a package or object reference"
+                                   : "on an undefined value");
            }
            stash = gv_stashpvn(packname, packlen, TRUE);
            goto fetch;
@@ -2565,11 +2580,23 @@ PP(pp_method)
     }
 
     if (!ob || !SvOBJECT(ob))
-       DIE(aTHX_ "Can't call method \"%s\" on unblessed reference", name);
+       Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
+                  name);
 
     stash = SvSTASH(ob);
 
   fetch:
+    /* shortcut for simple names */
+    if (hashp) {
+       HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
+       if (he) {
+           gv = (GV*)HeVAL(he);
+           if (isGV(gv) && GvCV(gv) &&
+               (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
+               return (SV*)GvCV(gv);
+       }
+    }
+
     gv = gv_fetchmethod(stash, name);
     if (!gv) {
        char* leaf = name;
@@ -2590,10 +2617,31 @@ PP(pp_method)
            packname = name;
            packlen = sep - name;
        }
-       DIE(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"",
-           leaf, (int)packlen, packname);
+       Perl_croak(aTHX_
+                  "Can't locate object method \"%s\" via package \"%s\"",
+                  leaf, packname);
     }
-    SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv);
-    RETURN;
+    return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
 }
 
+#ifdef USE_THREADS
+static void
+unset_cvowner(pTHXo_ void *cvarg)
+{
+    register CV* cv = (CV *) cvarg;
+#ifdef DEBUGGING
+    dTHR;
+#endif /* DEBUGGING */
+
+    DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
+                          thr, cv, SvPEEK((SV*)cv))));
+    MUTEX_LOCK(CvMUTEXP(cv));
+    DEBUG_S(if (CvDEPTH(cv) != 0)
+               PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
+                             CvDEPTH(cv)););
+    assert(thr == CvOWNER(cv));
+    CvOWNER(cv) = 0;
+    MUTEX_UNLOCK(CvMUTEXP(cv));
+    SvREFCNT_dec(cv);
+}
+#endif /* USE_THREADS */