This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
POD fixes and nits in re.pm
[perl5.git] / op.c
diff --git a/op.c b/op.c
index 0e668fb..5325a5a 100644 (file)
--- a/op.c
+++ b/op.c
@@ -640,7 +640,7 @@ Perl_scalar(pTHX_ OP *o)
            else
                scalar(kid);
        }
-       WITH_THR(PL_curcop = &PL_compiling);
+       PL_curcop = &PL_compiling;
        break;
     case OP_SCOPE:
     case OP_LINESEQ:
@@ -651,7 +651,7 @@ Perl_scalar(pTHX_ OP *o)
            else
                scalar(kid);
        }
-       WITH_THR(PL_curcop = &PL_compiling);
+       PL_curcop = &PL_compiling;
        break;
     case OP_SORT:
        if (ckWARN(WARN_VOID))
@@ -988,7 +988,7 @@ Perl_list(pTHX_ OP *o)
            else
                list(kid);
        }
-       WITH_THR(PL_curcop = &PL_compiling);
+       PL_curcop = &PL_compiling;
        break;
     case OP_SCOPE:
     case OP_LINESEQ:
@@ -998,7 +998,7 @@ Perl_list(pTHX_ OP *o)
            else
                list(kid);
        }
-       WITH_THR(PL_curcop = &PL_compiling);
+       PL_curcop = &PL_compiling;
        break;
     case OP_REQUIRE:
        /* all requires must return a boolean value */
@@ -1876,7 +1876,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
     {
       const char * const desc
          = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
-            ? rtype : OP_MATCH];
+                      ? (int)rtype : OP_MATCH];
       const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
             ? "@array" : "%hash");
       Perl_warner(aTHX_ packWARN(WARN_MISC),
@@ -2118,8 +2118,8 @@ Perl_fold_constants(pTHX_ register OP *o)
     dVAR;
     register OP *curop;
     OP *newop;
-    I32 type = o->op_type;
-    SV *sv = NULL;
+    VOL I32 type = o->op_type;
+    SV * VOL sv = NULL;
     int ret = 0;
     I32 oldscope;
     OP *old_next;
@@ -2233,7 +2233,7 @@ Perl_fold_constants(pTHX_ register OP *o)
     if (type == OP_RV2GV)
        newop = newGVOP(OP_GV, 0, (GV*)sv);
     else
-       newop = newSVOP(OP_CONST, 0, sv);
+       newop = newSVOP(OP_CONST, 0, (SV*)sv);
     op_getmad(o,newop,'f');
     return newop;
 
@@ -2258,6 +2258,8 @@ Perl_gen_constant_list(pTHX_ register OP *o)
     pp_pushmark();
     CALLRUNOPS(aTHX);
     PL_op = curop;
+    assert (!(curop->op_flags & OPf_SPECIAL));
+    assert(curop->op_type == OP_RANGE);
     pp_anonlist();
     PL_tmps_floor = oldtmps_floor;
 
@@ -3223,7 +3225,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
         if (DO_UTF8(pat))
            pm->op_pmdynflags |= PMdf_UTF8;
        /* FIXME - can we make this function take const char * args?  */
-       PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
+       PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
        if (strEQ("\\s+", PM_GETRE(pm)->precomp))
            pm->op_pmflags |= PMf_WHITE;
 #ifdef PERL_MAD
@@ -3783,7 +3785,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
         * to store these values, evil chicanery is done with SvCUR().
         */
 
-       if (!(left->op_private & OPpLVAL_INTRO)) {
+       {
            OP *lastop = o;
            PL_generation++;
            for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
@@ -3838,6 +3840,34 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
            if (curop != o)
                o->op_private |= OPpASSIGN_COMMON;
        }
+
+       if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
+               && (left->op_type == OP_LIST
+                   || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
+       {
+           OP* lop = ((LISTOP*)left)->op_first;
+           while (lop) {
+               if (lop->op_type == OP_PADSV ||
+                   lop->op_type == OP_PADAV ||
+                   lop->op_type == OP_PADHV ||
+                   lop->op_type == OP_PADANY)
+               {
+                   if (lop->op_private & OPpPAD_STATE) {
+                       if (left->op_private & OPpLVAL_INTRO) {
+                           o->op_private |= OPpASSIGN_STATE;
+                           /* hijacking PADSTALE for uninitialized state variables */
+                           SvPADSTALE_on(PAD_SVl(lop->op_targ));
+                       }
+                       else { /* we already checked for WARN_MISC before */
+                           Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
+                                   PAD_COMPNAME_PV(lop->op_targ));
+                       }
+                   }
+               }
+               lop = lop->op_sibling;
+           }
+       }
+
        if (right && right->op_type == OP_SPLIT) {
            OP* tmpop = ((LISTOP*)right)->op_first;
            if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
@@ -4525,7 +4555,7 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP
        loop = tmp;
     }
 #else
-    loop = PerlMemShared_realloc(loop, sizeof(LOOP));
+    loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
 #endif
     loop->op_targ = padoff;
     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
@@ -5312,7 +5342,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        else
            s = tname;
 
-       if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
+       if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
            goto done;
 
        if (strEQ(s, "BEGIN") && !PL_error_count) {
@@ -5340,6 +5370,15 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            av_store(PL_endav, 0, (SV*)cv);
            GvCV(gv) = 0;               /* cv has been hijacked */
        }
+       else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
+           /* It's never too late to run a unitcheck block */
+           if (!PL_unitcheckav)
+               PL_unitcheckav = newAV();
+           DEBUG_x( dump_sub(gv) );
+           av_unshift(PL_unitcheckav, 1);
+           av_store(PL_unitcheckav, 0, (SV*)cv);
+           GvCV(gv) = 0;               /* cv has been hijacked */
+       }
        else if (strEQ(s, "CHECK") && !PL_error_count) {
            if (!PL_checkav)
                PL_checkav = newAV();
@@ -5414,6 +5453,7 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
     cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
     CvXSUBANY(cv).any_ptr = sv;
     CvCONST_on(cv);
+    Safefree(file);
 
 #ifdef USE_ITHREADS
     if (stash)
@@ -5653,15 +5693,13 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
 OP *
 Perl_newANONLIST(pTHX_ OP *o)
 {
-    return newUNOP(OP_REFGEN, 0,
-       mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
+    return convert(OP_ANONLIST, OPf_SPECIAL, o);
 }
 
 OP *
 Perl_newANONHASH(pTHX_ OP *o)
 {
-    return newUNOP(OP_REFGEN, 0,
-       mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
+    return convert(OP_ANONHASH, OPf_SPECIAL, o);
 }
 
 OP *
@@ -6071,24 +6109,24 @@ Perl_ck_rvconst(pTHX_ register OP *o)
        /* Is it a constant from cv_const_sv()? */
        if (SvROK(kidsv) && SvREADONLY(kidsv)) {
            SV * const rsv = SvRV(kidsv);
-           const int svtype = SvTYPE(rsv);
+           const svtype type = SvTYPE(rsv);
             const char *badtype = NULL;
 
            switch (o->op_type) {
            case OP_RV2SV:
-               if (svtype > SVt_PVMG)
+               if (type > SVt_PVMG)
                    badtype = "a SCALAR";
                break;
            case OP_RV2AV:
-               if (svtype != SVt_PVAV)
+               if (type != SVt_PVAV)
                    badtype = "an ARRAY";
                break;
            case OP_RV2HV:
-               if (svtype != SVt_PVHV)
+               if (type != SVt_PVHV)
                    badtype = "a HASH";
                break;
            case OP_RV2CV:
-               if (svtype != SVt_PVCV)
+               if (type != SVt_PVCV)
                    badtype = "a CODE";
                break;
            }
@@ -6716,16 +6754,6 @@ Perl_ck_listiob(pTHX_ OP *o)
 }
 
 OP *
-Perl_ck_say(pTHX_ OP *o)
-{
-    o = ck_listiob(o);
-    o->op_type = OP_PRINT;
-    cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
-       = newSVOP(OP_CONST, 0, newSVpvs("\n"));
-    return o;
-}
-
-OP *
 Perl_ck_smartmatch(pTHX_ OP *o)
 {
     dVAR;
@@ -7275,7 +7303,7 @@ Perl_ck_subr(pTHX_ OP *o)
     int optional = 0;
     I32 arg = 0;
     I32 contextclass = 0;
-    char *e = NULL;
+    const char *e = NULL;
     bool delete_op = 0;
 
     o->op_private |= OPpENTERSUB_HASTARG;
@@ -7298,13 +7326,20 @@ Perl_ck_subr(pTHX_ OP *o)
                    proto_end = proto + len;
                }
                if (CvASSERTION(cv)) {
-                   if (PL_hints & HINT_ASSERTING) {
+                   U32 asserthints = 0;
+                   HV *const hinthv = GvHV(PL_hintgv);
+                   if (hinthv) {
+                       SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
+                       if (svp && *svp)
+                           asserthints = SvUV(*svp);
+                   }
+                   if (asserthints & HINT_ASSERTING) {
                        if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
                            o->op_private |= OPpENTERSUB_DB;
                    }
                    else {
                        delete_op = 1;
-                       if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
+                       if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
                            Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
                                        "Impossible to activate assertion call");
                        }
@@ -7340,6 +7375,10 @@ Perl_ck_subr(pTHX_ OP *o)
                optional = 1;
                proto++;
                continue;
+           case '_':
+               /* _ must be at the end */
+               if (proto[1] && proto[1] != ';')
+                   goto oops;
            case '$':
                proto++;
                arg++;
@@ -7499,8 +7538,14 @@ Perl_ck_subr(pTHX_ OP *o)
        prev = o2;
        o2 = o2->op_sibling;
     } /* while */
+    if (o2 == cvop && proto && *proto == '_') {
+       /* generate an access to $_ */
+       o2 = newDEFSVOP();
+       o2->op_sibling = prev->op_sibling;
+       prev->op_sibling = o2; /* instead of cvop */
+    }
     if (proto && !optional && proto_end > proto &&
-       (*proto != '@' && *proto != '%' && *proto != ';'))
+       (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
        return too_few_arguments(o, gv_ename(namegv));
     if(delete_op) {
 #ifdef PERL_MAD
Unnamed repository; edit this file 'description' to name the repository.