phase 1 of somewhat major rearrangement of PERL_OBJECT stuff

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

diff --git a/pp_ctl.c b/pp_ctl.c
index 332b24c..c9ccb3a 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)
@@ -747,6 +749,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 +815,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 +852,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 +868,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++;
        }
     }
@@ -858,8 +920,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 +1047,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 +1167,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 +1203,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:
@@ -1227,6 +1293,8 @@ die_where(char *message)
            return pop_return();
        }
     }
+    if (!message)
+       message = SvPVx(ERRSV, PL_na);
     PerlIO_printf(PerlIO_stderr(), "%s",message);
     PerlIO_flush(PerlIO_stderr());
     my_failure_exit();
@@ -1873,6 +1941,7 @@ PP(pp_goto)
            SV** mark;
            I32 items = 0;
            I32 oldsave;
+           int arg_was_real = 0;
 
        retry:
            if (!CvROOT(cv) && !CvXSUB(cv)) {
@@ -1917,7 +1986,10 @@ PP(pp_goto)
                SvREFCNT_dec(GvAV(PL_defgv));
                GvAV(PL_defgv) = cx->blk_sub.savearray;
 #endif /* USE_THREADS */
-               AvREAL_off(av);
+               if (AvREAL(av)) {
+                   arg_was_real = 1;
+                   AvREAL_off(av);     /* so av_clear() won't clobber elts */
+               }
                av_clear(av);
            }
            else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
@@ -2073,7 +2145,11 @@ PP(pp_goto)
                    }
                    Copy(mark,AvARRAY(av),items,SV*);
                    AvFILLp(av) = items - 1;
-                   
+                   /* preserve @_ nature */
+                   if (arg_was_real) {
+                       AvREIFY_off(av);
+                       AvREAL_on(av);
+                   }
                    while (items--) {
                        if (*mark)
                            SvTEMP_off(*mark);
@@ -2308,15 +2384,14 @@ docatch(OP *o)
     JMPENV_PUSH(ret);
     switch (ret) {
     default:                           /* topmost level handles it */
+pass_the_buck:
        JMPENV_POP;
        PL_op = oldop;
        JMPENV_JUMP(ret);
        /* NOTREACHED */
     case 3:
-       if (!PL_restartop) {
-           PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
-           break;
-       }
+       if (!PL_restartop)
+           goto pass_the_buck;
        PL_op = PL_restartop;
        PL_restartop = 0;
        /* FALL THROUGH */
@@ -2384,7 +2459,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;
@@ -2644,6 +2719,7 @@ PP(pp_require)
 #else
                sv_setpvf(namesv, "%s/%s", dir, name);
 #endif
+               TAINT_PROPER("require");
                tryname = SvPVX(namesv);
                tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
                if (tryrsfp) {
@@ -2690,10 +2766,8 @@ PP(pp_require)
     ENTER;
     SAVETMPS;
     lex_start(sv_2mortal(newSVpv("",0)));
-    if (PL_rsfp_filters){
-       save_aptr(&PL_rsfp_filters);
-       PL_rsfp_filters = NULL;
-    }
+    SAVEGENERICSV(PL_rsfp_filters);
+    PL_rsfp_filters = Nullav;
 
     PL_rsfp = tryrsfp;
     name = savepv(name);