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
merge perly.y and madlu.y
[perl5.git] / op.c
diff --git a/op.c b/op.c
index c9f6171..ab84ef1 100644 (file)
--- a/op.c
+++ b/op.c
@@ -490,7 +490,19 @@ clear_pmop:
 STATIC void
 S_cop_free(pTHX_ COP* cop)
 {
-    Safefree(cop->cop_label);   /* FIXME: treaddead ??? */
+    if (cop->cop_label) {
+#ifdef PERL_TRACK_MEMPOOL
+       Malloc_t ptr = (Malloc_t)(cop->cop_label - sTHX);
+       struct perl_memory_debug_header *const header
+               = (struct perl_memory_debug_header *)ptr;
+       /* Only the thread that allocated us can free us. */
+       if (header->interpreter == aTHX)
+#endif
+       {
+           Safefree(cop->cop_label);
+           cop->cop_label = NULL;
+       }
+    }
     CopFILE_free(cop);
     CopSTASH_free(cop);
     if (! specialWARN(cop->cop_warnings))
@@ -1769,7 +1781,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
               type == OP_RV2AV ||
               type == OP_RV2HV) { /* XXX does this let anything illegal in? */
        if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
-           yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
+           yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
                        OP_DESC(o),
                        PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
        } else if (attrs) {
@@ -2118,8 +2130,8 @@ Perl_fold_constants(pTHX_ register OP *o)
     dVAR;
     register OP *curop;
     OP *newop;
-    volatile I32 type = o->op_type;
-    volatile SV *sv = NULL;
+    VOL I32 type = o->op_type;
+    SV * VOL sv = NULL;
     int ret = 0;
     I32 oldscope;
     OP *old_next;
@@ -2258,6 +2270,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;
 
@@ -2993,6 +3007,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            bits = 8;
 
        Safefree(cPVOPo->op_pv);
+       cPVOPo->op_pv = NULL;
        cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
        SvREFCNT_dec(listsv);
        SvREFCNT_dec(transv);
@@ -3223,7 +3238,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
@@ -3312,7 +3327,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
        if (curop == repl
            && !(repl_has_vars
                 && (!PM_GETRE(pm)
-                    || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
+                    || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN))) {
            pm->op_pmflags |= PMf_CONST;        /* const for long enough */
            pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
            prepend_elem(o->op_type, scalar(repl), o);
@@ -3987,10 +4002,13 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
     CopSTASH_set(cop, PL_curstash);
 
     if (PERLDB_LINE && PL_curstash != PL_debstash) {
-       SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
-       if (svp && *svp != &PL_sv_undef ) {
-           (void)SvIOK_on(*svp);
-           SvIV_set(*svp, PTR2IV(cop));
+       AV *av = CopFILEAVx(PL_curcop);
+       if (av) {
+           SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
+           if (svp && *svp != &PL_sv_undef ) {
+               (void)SvIOK_on(*svp);
+               SvIV_set(*svp, PTR2IV(cop));
+           }
        }
     }
 
@@ -4789,7 +4807,7 @@ Perl_cv_undef(pTHX_ CV *cv)
        /* for XSUBs CvFILE point directly to static memory; __FILE__ */
        Safefree(CvFILE(cv));
     }
-    CvFILE(cv) = 0;
+    CvFILE(cv) = NULL;
 #endif
 
     if (!CvISXSUB(cv) && CvROOT(cv)) {
@@ -5340,7 +5358,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) {
@@ -5368,6 +5386,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();
@@ -5442,6 +5469,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)
@@ -5681,15 +5709,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 *
@@ -6744,16 +6770,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;
@@ -7326,13 +7342,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");
                        }
@@ -7368,6 +7391,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++;
@@ -7527,8 +7554,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.