Implement handling of state variables in list assignment
[p5sagit/p5-mst-13.2.git] / pp_ctl.c
index 485a004..929f5a2 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -197,7 +197,7 @@ PP(pp_substcont)
     if(old != rx) {
        if(old)
            ReREFCNT_dec(old);
-       PM_SETRE(pm,rx);
+       PM_SETRE(pm,ReREFCNT_inc(rx));
     }
 
     rxres_restore(&cx->sb_rxres, rx);
@@ -245,7 +245,6 @@ PP(pp_substcont)
            if (DO_UTF8(dstr))
                SvUTF8_on(targ);
            SvPV_set(dstr, NULL);
-           sv_free(dstr);
 
            TAINT_IF(cx->sb_rxtainted & 1);
            PUSHs(sv_2mortal(newSViv(saviters - 1)));
@@ -256,7 +255,6 @@ PP(pp_substcont)
            SvTAINT(targ);
 
            LEAVE_SCOPE(cx->sb_oldsave);
-           ReREFCNT_dec(rx);
            POPSUBST(cx);
            RETURNOP(pm->op_next);
        }
@@ -831,11 +829,7 @@ PP(pp_formline)
            /* Formats aren't yet marked for locales, so assume "yes". */
            {
                STORE_NUMERIC_STANDARD_SET_LOCAL();
-#ifdef USE_SNPRINTF
-               snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
-#else
-               sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
-#endif /* ifdef USE_SNPRINTF */
+               my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
                RESTORE_NUMERIC_STANDARD();
            }
            t += fieldsize;
@@ -1454,7 +1448,7 @@ Perl_qerror(pTHX_ SV *err)
     else if (PL_errors)
        sv_catsv(PL_errors, err);
     else
-       Perl_warn(aTHX_ "%"SVf, err);
+       Perl_warn(aTHX_ "%"SVf, (void*)err);
     ++PL_error_count;
 }
 
@@ -1725,10 +1719,10 @@ PP(pp_caller)
         PUSHs(sv_2mortal(mask));
     }
 
-    PUSHs(cx->blk_oldcop->cop_hints ?
+    PUSHs(cx->blk_oldcop->cop_hints_hash ?
          sv_2mortal(newRV_noinc(
-               (SV*)Perl_refcounted_he_chain_2hv(aTHX_
-                                                 cx->blk_oldcop->cop_hints)))
+           (SV*)Perl_refcounted_he_chain_2hv(aTHX_
+                                             cx->blk_oldcop->cop_hints_hash)))
          : &PL_sv_undef);
     RETURN;
 }
@@ -2016,7 +2010,7 @@ PP(pp_return)
            /* Unassume the success we assumed earlier. */
            SV * const nsv = cx->blk_eval.old_namesv;
            (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
-           DIE(aTHX_ "%"SVf" did not return a true value", nsv);
+           DIE(aTHX_ "%"SVf" did not return a true value", (void*)nsv);
        }
        break;
     case CXt_FORMAT:
@@ -2324,7 +2318,7 @@ PP(pp_goto)
                        goto retry;
                    tmpstr = sv_newmortal();
                    gv_efullname3(tmpstr, gv, NULL);
-                   DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
+                   DIE(aTHX_ "Goto undefined subroutine &%"SVf"",(void*)tmpstr);
                }
                DIE(aTHX_ "Goto undefined subroutine");
            }
@@ -2417,7 +2411,7 @@ PP(pp_goto)
 
                CvDEPTH(cv)++;
                if (CvDEPTH(cv) < 2)
-                   SvREFCNT_inc_void_NN(cv);
+                   SvREFCNT_inc_simple_void_NN(cv);
                else {
                    if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
                        sub_crush_depth(cv);
@@ -2773,13 +2767,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
        len = SvCUR(sv);
     }
     else
-#ifdef USE_SNPRINTF
-       len = snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
-                      (unsigned long)++PL_evalseq);
-#else
-       len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
-                        (unsigned long)++PL_evalseq);
-#endif /* ifdef USE_SNPRINTF */
+       len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
+                         (unsigned long)++PL_evalseq);
     SAVECOPFILE_FREE(&PL_compiling);
     CopFILE_set(&PL_compiling, tmpbuf+2);
     SAVECOPLINE(&PL_compiling);
@@ -3030,6 +3019,7 @@ S_check_type_and_open(pTHX_ const char *name, const char *mode)
 {
     Stat_t st;
     const int st_rc = PerlLIO_stat(name, &st);
+
     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
        return NULL;
     }
@@ -3094,14 +3084,14 @@ PP(pp_require)
        if (!sv_derived_from(PL_patchlevel, "version"))
            upg_version(PL_patchlevel);
        if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
-           if ( vcmp(sv,PL_patchlevel) < 0 )
+           if ( vcmp(sv,PL_patchlevel) <= 0 )
                DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
-                   vnormal(sv), vnormal(PL_patchlevel));
+                   (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
        }
        else {
            if ( vcmp(sv,PL_patchlevel) > 0 )
                DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
-                   vnormal(sv), vnormal(PL_patchlevel));
+                   (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
        }
 
            RETPUSHYES;
@@ -3147,7 +3137,7 @@ PP(pp_require)
        {
            namesv = newSV(0);
            for (i = 0; i <= AvFILL(ar); i++) {
-               SV *dirsv = *av_fetch(ar, i, TRUE);
+               SV * const dirsv = *av_fetch(ar, i, TRUE);
 
                if (SvROK(dirsv)) {
                    int count;
@@ -3188,7 +3178,7 @@ PP(pp_require)
                        if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
                            && !isGV_with_GP(SvRV(arg))) {
                            filter_cache = SvRV(arg);
-                           SvREFCNT_inc_void_NN(filter_cache);
+                           SvREFCNT_inc_simple_void_NN(filter_cache);
 
                            if (i < count) {
                                arg = SP[i++];
@@ -3200,7 +3190,7 @@ PP(pp_require)
                        }
 
                        if (SvTYPE(arg) == SVt_PVGV) {
-                           IO *io = GvIO((GV *)arg);
+                           IO * const io = GvIO((GV *)arg);
 
                            ++filter_has_file;
 
@@ -3220,7 +3210,7 @@ PP(pp_require)
 
                        if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
                            filter_sub = arg;
-                           SvREFCNT_inc_void_NN(filter_sub);
+                           SvREFCNT_inc_simple_void_NN(filter_sub);
 
                            if (i < count) {
                                filter_state = SP[i];
@@ -3307,6 +3297,9 @@ PP(pp_require)
                            tryname += 2;
                        break;
                    }
+                   else if (errno == EMFILE)
+                       /* no point in trying other paths if out of handles */
+                       break;
                  }
                }
            }
@@ -3383,8 +3376,6 @@ PP(pp_require)
     }
     else
         PL_compiling.cop_warnings = pWARN_STD ;
-    SAVESPTR(PL_compiling.cop_io);
-    PL_compiling.cop_io = NULL;
 
     if (filter_sub || filter_cache) {
        SV * const datasv = filter_add(S_run_user_filter, NULL);
@@ -3460,11 +3451,7 @@ PP(pp_entereval)
        len = SvCUR(temp_sv);
     }
     else
-#ifdef USE_SNPRINTF
-       len = snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
-#else
-       len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
-#endif /* ifdef USE_SNPRINTF */
+       len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
     SAVECOPFILE_FREE(&PL_compiling);
     CopFILE_set(&PL_compiling, tmpbuf+2);
     SAVECOPLINE(&PL_compiling);
@@ -3482,20 +3469,13 @@ PP(pp_entereval)
        GvHV(PL_hintgv) = saved_hh;
     SAVECOMPILEWARNINGS();
     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
-    SAVESPTR(PL_compiling.cop_io);
-    if (specialCopIO(PL_curcop->cop_io))
-        PL_compiling.cop_io = PL_curcop->cop_io;
-    else {
-        PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
-        SAVEFREESV(PL_compiling.cop_io);
+    if (PL_compiling.cop_hints_hash) {
+       Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
     }
-    if (PL_compiling.cop_hints) {
-       Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
-    }
-    PL_compiling.cop_hints = PL_curcop->cop_hints;
-    if (PL_compiling.cop_hints) {
+    PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
+    if (PL_compiling.cop_hints_hash) {
        HINTS_REFCNT_LOCK;
-       PL_compiling.cop_hints->refcounted_he_refcnt++;
+       PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
        HINTS_REFCNT_UNLOCK;
     }
     /* special case: an eval '' executed within the DB package gets lexically
@@ -3583,7 +3563,7 @@ PP(pp_leaveeval)
        /* Unassume the success we assumed earlier. */
        SV * const nsv = cx->blk_eval.old_namesv;
        (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
-       retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
+       retop = Perl_die(aTHX_ "%"SVf" did not return a true value", (void*)nsv);
        /* die_where() did LEAVE, or we won't be here */
     }
     else {
@@ -3644,7 +3624,7 @@ Perl_create_eval_scope(pTHX_ U32 flags)
 PP(pp_entertry)
 {
     dVAR;
-    PERL_CONTEXT *cx = create_eval_scope(0);
+    PERL_CONTEXT * const cx = create_eval_scope(0);
     cx->blk_eval.retop = cLOGOP->op_other->op_next;
     return DOCATCH(PL_op->op_next);
 }
@@ -3788,42 +3768,8 @@ PP(pp_smartmatch)
     return do_smartmatch(NULL, NULL);
 }
 
-/* This version of do_smartmatch() implements the following
-   table of smart matches:
-    
-    $a      $b        Type of Match Implied    Matching Code
-    ======  =====     =====================    =============
-    (overloading trumps everything)
-
-    Code[+] Code[+]   referential equality     match if refaddr($a) == refaddr($b)
-    Any     Code[+]   scalar sub truth         match if $b->($a)
-
-    Hash    Hash      hash keys identical      match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
-    Hash    Array     hash value slice truth   match if $a->{any(@$b)}
-    Hash    Regex     hash key grep            match if any(keys(%$a)) =~ /$b/
-    Hash    Any       hash entry existence     match if exists $a->{$b}
-
-    Array   Array     arrays are identical[*]  match if $a È~~Ç $b
-    Array   Regex     array grep               match if any(@$a) =~ /$b/
-    Array   Num       array contains number    match if any($a) == $b
-    Array   Any       array contains string    match if any($a) eq $b
-
-    Any     undef     undefined                match if !defined $a
-    Any     Regex     pattern match            match if $a =~ /$b/
-    Code()  Code()    results are equal        match if $a->() eq $b->()
-    Any     Code()    simple closure truth     match if $b->() (ignoring $a)
-    Num     numish[!] numeric equality         match if $a == $b
-    Any     Str       string equality          match if $a eq $b
-    Any     Num       numeric equality         match if $a == $b
-
-    Any     Any       string equality          match if $a eq $b
-
-
- + - this must be a code reference whose prototype (if present) is not ""
-     (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
- * - if a circular reference is found, we fall back to referential equality
- ! - either a real number, or a string that looks_like_number()
-
+/* This version of do_smartmatch() implements the
+ * table of smart matches that is found in perlsyn.
  */
 STATIC
 OP *
@@ -3914,7 +3860,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
        if (c == 0)
            PUSHs(&PL_sv_no);
        else if (SvTEMP(TOPs))
-           SvREFCNT_inc(TOPs);
+           SvREFCNT_inc_void(TOPs);
        FREETMPS;
        LEAVE;
        RETURN;
@@ -4155,7 +4101,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
        if (c == 0)
            PUSHs(&PL_sv_undef);
        else if (SvTEMP(TOPs))
-           SvREFCNT_inc(TOPs);
+           SvREFCNT_inc_void(TOPs);
 
        if (SM_OTHER_REF(PVCV)) {
            /* This one has to be null-proto'd too.
@@ -4166,7 +4112,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
            if (c == 0)
                PUSHs(&PL_sv_undef);
            else if (SvTEMP(TOPs))
-               SvREFCNT_inc(TOPs);
+               SvREFCNT_inc_void(TOPs);
            FREETMPS;
            LEAVE;
            PUTBACK;
@@ -4560,7 +4506,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
     int status = 0;
     SV *upstream;
     STRLEN got_len;
-    const char *got_p;
+    const char *got_p = NULL;
     const char *prune_from = NULL;
     bool read_from_cache = FALSE;
     STRLEN umaxlen;