applied suggested patch with PERL_OBJECT tweaks

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

diff --git a/pp_ctl.c b/pp_ctl.c
index f90eff9..a4fabd2 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -41,6 +41,8 @@ static void save_lines _((AV *array, SV *sv));
 static I32 sortcv _((SV *a, SV *b));
 static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
 static OP *doeval _((int gimme, OP** startop));
+static I32 amagic_cmp _((SV *str1, SV *str2));
+static I32 amagic_cmp_locale _((SV *str1, SV *str2));
 #endif
 
 PP(pp_wantarray)
@@ -162,8 +164,9 @@ PP(pp_substcont)
 
        /* Are we done */
        if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
-                                    s == m, Nullsv, NULL,
-                                    cx->sb_safebase ? 0 : REXEC_COPY_STR))
+                                    s == m, cx->sb_targ, NULL,
+                                    ((cx->sb_rflags & REXEC_COPY_STR)
+                                     ? 0 : REXEC_COPY_STR)))
        {
            SV *targ = cx->sb_targ;
            sv_catpvn(dstr, s, cx->sb_strend - s);
@@ -615,7 +618,13 @@ PP(pp_formline)
            break;
 
        case FF_MORE:
-           if (itemsize) {
+           s = chophere;
+           send = item + len;
+           if (chopspace) {
+               while (*s && isSPACE(*s) && s < send)
+                   s++;
+           }
+           if (s < send) {
                arg = fieldsize - itemsize;
                if (arg) {
                    fieldsize -= arg;
@@ -747,6 +756,61 @@ PP(pp_mapwhile)
     }
 }
 
+#define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
+         *svp = Nullsv;                                \
+          if (PL_amagic_generation) { \
+           if (SvAMAGIC(left)||SvAMAGIC(right))\
+               *svp = amagic_call(left, \
+                                  right, \
+                                  CAT2(meth,_amg), \
+                                  0); \
+         } \
+       } STMT_END
+
+STATIC I32
+amagic_cmp(register SV *str1, register SV *str2)
+{
+    SV *tmpsv;
+    tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
+    if (tmpsv) {
+       double d;
+       
+        if (SvIOK(tmpsv)) {
+            I32 i = SvIVX(tmpsv);
+            if (i > 0)
+               return 1;
+            return i? -1 : 0;
+        }
+        d = SvNV(tmpsv);
+        if (d > 0)
+           return 1;
+        return d? -1 : 0;
+    }
+    return sv_cmp(str1, str2);
+}
+
+STATIC I32
+amagic_cmp_locale(register SV *str1, register SV *str2)
+{
+    SV *tmpsv;
+    tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
+    if (tmpsv) {
+       double d;
+       
+        if (SvIOK(tmpsv)) {
+            I32 i = SvIVX(tmpsv);
+            if (i > 0)
+               return 1;
+            return i? -1 : 0;
+        }
+        d = SvNV(tmpsv);
+        if (d > 0)
+           return 1;
+        return d? -1 : 0;
+    }
+    return sv_cmp_locale(str1, str2);
+}
+
 PP(pp_sort)
 {
     djSP; dMARK; dORIGMARK;
@@ -758,6 +822,7 @@ PP(pp_sort)
     CV *cv;
     I32 gimme = GIMME;
     OP* nextop = PL_op->op_next;
+    I32 overloading = 0;
 
     if (gimme != G_ARRAY) {
        SP = MARK;
@@ -794,7 +859,7 @@ PP(pp_sort)
            }
            PL_sortcop = CvSTART(cv);
            SAVESPTR(CvROOT(cv)->op_ppaddr);
-           CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
+           CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 
            SAVESPTR(PL_curpad);
            PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
@@ -810,8 +875,12 @@ PP(pp_sort)
        /*SUPPRESS 560*/
        if (*up = *++MARK) {                    /* Weed out nulls. */
            SvTEMP_off(*up);
-           if (!PL_sortcop && !SvPOK(*up))
-               (void)sv_2pv(*up, &PL_na);
+           if (!PL_sortcop && !SvPOK(*up)) {
+               if (SvAMAGIC(*up))
+                   overloading = 1;
+               else
+                   (void)sv_2pv(*up, &PL_na);
+           }
            up++;
        }
     }
@@ -849,6 +918,7 @@ PP(pp_sort)
            qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
 
            POPBLOCK(cx,PL_curpm);
+           PL_stack_sp = newsp;
            POPSTACK;
            CATCH_SET(oldcatch);
        }
@@ -858,8 +928,12 @@ PP(pp_sort)
            MEXTEND(SP, 20);    /* Can't afford stack realloc on signal. */
            qsortsv(ORIGMARK+1, max,
                    (PL_op->op_private & OPpLOCALE)
-                   ? FUNC_NAME_TO_PTR(sv_cmp_locale)
-                   : FUNC_NAME_TO_PTR(sv_cmp));
+                   ? ( overloading
+                       ? FUNC_NAME_TO_PTR(amagic_cmp_locale)
+                       : FUNC_NAME_TO_PTR(sv_cmp_locale))
+                   : ( overloading 
+                       ? FUNC_NAME_TO_PTR(amagic_cmp)
+                       : FUNC_NAME_TO_PTR(sv_cmp) ));
        }
     }
     LEAVE;
@@ -981,22 +1055,22 @@ dopoptolabel(char *label)
        case CXt_SUBST:
            if (ckWARN(WARN_UNSAFE))
                warner(WARN_UNSAFE, "Exiting substitution via %s", 
-                       op_name[PL_op->op_type]);
+                       PL_op_name[PL_op->op_type]);
            break;
        case CXt_SUB:
            if (ckWARN(WARN_UNSAFE))
                warner(WARN_UNSAFE, "Exiting subroutine via %s", 
-                       op_name[PL_op->op_type]);
+                       PL_op_name[PL_op->op_type]);
            break;
        case CXt_EVAL:
            if (ckWARN(WARN_UNSAFE))
                warner(WARN_UNSAFE, "Exiting eval via %s", 
-                       op_name[PL_op->op_type]);
+                       PL_op_name[PL_op->op_type]);
            break;
        case CXt_NULL:
            if (ckWARN(WARN_UNSAFE))
                warner(WARN_UNSAFE, "Exiting pseudo-block via %s", 
-                       op_name[PL_op->op_type]);
+                       PL_op_name[PL_op->op_type]);
            return -1;
        case CXt_LOOP:
            if (!cx->blk_loop.label ||
@@ -1101,22 +1175,22 @@ dopoptoloop(I32 startingblock)
        case CXt_SUBST:
            if (ckWARN(WARN_UNSAFE))
                warner(WARN_UNSAFE, "Exiting substitution via %s", 
-                       op_name[PL_op->op_type]);
+                       PL_op_name[PL_op->op_type]);
            break;
        case CXt_SUB:
            if (ckWARN(WARN_UNSAFE))
                warner(WARN_UNSAFE, "Exiting subroutine via %s", 
-                       op_name[PL_op->op_type]);
+                       PL_op_name[PL_op->op_type]);
            break;
        case CXt_EVAL:
            if (ckWARN(WARN_UNSAFE))
                warner(WARN_UNSAFE, "Exiting eval via %s", 
-                       op_name[PL_op->op_type]);
+                       PL_op_name[PL_op->op_type]);
            break;
        case CXt_NULL:
            if (ckWARN(WARN_UNSAFE))
                warner(WARN_UNSAFE, "Exiting pseudo-block via %s", 
-                       op_name[PL_op->op_type]);
+                       PL_op_name[PL_op->op_type]);
            return -1;
        case CXt_LOOP:
            DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
@@ -1137,7 +1211,7 @@ dounwind(I32 cxix)
     while (cxstack_ix > cxix) {
        cx = &cxstack[cxstack_ix];
        DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
-                             (long) cxstack_ix, block_type[CxTYPE(cx)]));
+                             (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
        /* Note: we don't need to restore the base context info till the end. */
        switch (CxTYPE(cx)) {
        case CXt_SUBST:
@@ -1186,6 +1260,10 @@ die_where(char *message)
                        SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
                        sv_catpvn(err, prefix, sizeof(prefix)-1);
                        sv_catpvn(err, message, klen);
+                       if (ckWARN(WARN_UNSAFE)) {
+                           STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
+                           warner(WARN_UNSAFE, SvPVX(err)+start);
+                       }
                    }
                    sv_inc(*svp);
                }
@@ -2393,7 +2471,7 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
     POPEVAL(cx);
 
     (*startop)->op_type = OP_NULL;
-    (*startop)->op_ppaddr = ppaddr[OP_NULL];
+    (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
     lex_end();
     *avp = (AV*)SvREFCNT_inc(PL_comppad);
     LEAVE;