PATCH: untaint method for IO::Handle, 5.003_06 version

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

diff --git a/pp_ctl.c b/pp_ctl.c
index 0e86fd1..0c7e3d4 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -212,9 +212,9 @@ PP(pp_formline)
            case FF_END:        name = "END";           break;
            }
            if (arg >= 0)
-               fprintf(stderr, "%-16s%ld\n", name, (long) arg);
+               PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
            else
-               fprintf(stderr, "%-16s\n", name);
+               PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
        } )
        switch (*fpc++) {
        case FF_LINEMARK:
@@ -574,7 +574,7 @@ PP(pp_sort)
            if (!(cv && CvROOT(cv))) {
                if (gv) {
                    SV *tmpstr = sv_newmortal();
-                   gv_efullname(tmpstr, gv);
+                   gv_efullname3(tmpstr, gv, Nullch);
                    if (cv && CvXSUB(cv))
                        DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
                    DIE("Undefined sort subroutine \"%s\" called",
@@ -881,7 +881,7 @@ I32 cxix;
 
     while (cxstack_ix > cxix) {
        cx = &cxstack[cxstack_ix--];
-       DEBUG_l(fprintf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
+       DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
                    block_type[cx->cx_type]));
        /* Note: we don't need to restore the base context info till the end. */
        switch (cx->cx_type) {
@@ -987,7 +987,7 @@ char *message;
 
            POPBLOCK(cx,curpm);
            if (cx->cx_type != CXt_EVAL) {
-               fprintf(stderr, "panic: die %s", message);
+               PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
                my_exit(1);
            }
            POPEVAL(cx);
@@ -1003,11 +1003,11 @@ char *message;
            return pop_return();
        }
     }
-    fputs(message, stderr);
-    (void)Fflush(stderr);
+    PerlIO_printf(PerlIO_stderr(), "%s",message);
+    PerlIO_flush(PerlIO_stderr());
     if (e_tmpname) {
        if (e_fp) {
-           fclose(e_fp);
+           PerlIO_close(e_fp);
            e_fp = Nullfp;
        }
        (void)UNLINK(e_tmpname);
@@ -1114,7 +1114,7 @@ PP(pp_caller)
        RETURN;
     if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
        sv = NEWSV(49, 0);
-       gv_efullname(sv, CvGV(cxstack[cxix].blk_sub.cv));
+       gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
        PUSHs(sv_2mortal(sv));
        PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
     }
@@ -1202,6 +1202,36 @@ const void *b;
     if (!SvPOKp(str2))
        return 1;
 
+    if (lc_collate_active) {   /* NOTE: this is the LC_COLLATE branch */
+      register char * pv1, * pv2, * pvx;
+      STRLEN cur1, cur2, curx;
+
+      pv1 = SvPV(str1, cur1);
+      pvx = mem_collxfrm(pv1, cur1, &curx);
+      pv1 = pvx;
+      cur1 = curx;
+
+      pv2 = SvPV(str2, cur2);
+      pvx = mem_collxfrm(pv2, cur2, &curx);
+      pv2 = pvx;
+      cur2 = curx;
+
+      retval = memcmp((void *)pv1, (void *)pv2, cur1 < cur2 ? cur1 : cur2);
+
+      Safefree(pv1);
+      Safefree(pv2);
+
+      if (retval)
+       return retval < 0 ? -1 : 1;
+
+      if (cur1 == cur2)
+       return 0;
+      else
+       return cur1 < cur2 ? -1 : 1;
+    }
+
+    /* NOTE: this is the non-LC_COLLATE area */
+
     if (SvCUR(str1) < SvCUR(str2)) {
        /*SUPPRESS 560*/
        if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1)))
@@ -1623,7 +1653,7 @@ PP(pp_goto)
            if (!CvROOT(cv) && !CvXSUB(cv)) {
                if (CvGV(cv)) {
                    SV *tmpstr = sv_newmortal();
-                   gv_efullname(tmpstr, CvGV(cv));
+                   gv_efullname3(tmpstr, CvGV(cv), Nullch);
                    DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
                }
                DIE("Goto undefined subroutine");
@@ -1760,12 +1790,13 @@ PP(pp_goto)
                        mark++;
                    }
                }
-               if (perldb && curstash != debstash) { /* &xsub is not copying @_ */
+               if (perldb && curstash != debstash) {
+                   /* &xsub is not copying @_ */
                    SV *sv = GvSV(DBsub);
                    save_item(sv);
-                   gv_efullname(sv, CvGV(cv)); /* We do not care about
-                                                * using sv to call CV,
-                                                * just for info. */
+                   gv_efullname3(sv, CvGV(cv), Nullch);
+                   /* We do not care about using sv to call CV,
+                    * just for info. */
                }
                RETURNOP(CvSTART(cv));
            }
@@ -2064,7 +2095,7 @@ PP(pp_require)
     char *tmpname;
     SV** svp;
     I32 gimme = G_SCALAR;
-    FILE *tryrsfp = 0;
+    PerlIO *tryrsfp = 0;
 
     sv = POPs;
     if (SvNIOKp(sv) && !SvPOKp(sv)) {
@@ -2098,7 +2129,7 @@ PP(pp_require)
 #endif
     )
     {
-       tryrsfp = fopen(tmpname,"r");
+       tryrsfp = PerlIO_open(tmpname,"r");
     }
     else {
        AV *ar = GvAVn(incgv);
@@ -2113,7 +2144,7 @@ PP(pp_require)
            (void)sprintf(buf, "%s/%s",
                SvPVx(*av_fetch(ar, i, TRUE), na), name);
 #endif
-           tryrsfp = fopen(buf, "r");
+           tryrsfp = PerlIO_open(buf, "r");
            if (tryrsfp) {
                char *s = buf;
 
@@ -2225,7 +2256,7 @@ PP(pp_leaveeval)
     I32 gimme;
     register CONTEXT *cx;
     OP *retop;
-    OP *saveop = op;
+    U8 save_flags = op -> op_flags;
     I32 optype;
 
     POPBLOCK(cx,newpm);
@@ -2252,7 +2283,7 @@ PP(pp_leaveeval)
     }
     else {
        for (mark = newsp + 1; mark <= SP; mark++)
-           if (!(SvFLAGS(TOPs) & SVs_TEMP))
+           if (!(SvFLAGS(*mark) & SVs_TEMP))
                *mark = sv_mortalcopy(*mark);
                /* in case LEAVE wipes old return values */
     }
@@ -2269,7 +2300,7 @@ PP(pp_leaveeval)
 
     lex_end();
     LEAVE;
-    if (!(saveop->op_flags & OPf_SPECIAL))
+    if (!(save_flags & OPf_SPECIAL))
        sv_setpv(GvSV(errgv),"");
 
     RETURNOP(retop);
@@ -2328,7 +2359,7 @@ PP(pp_leavetry)
     }
     else {
        for (mark = newsp + 1; mark <= SP; mark++)
-           if (!(SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)))
+           if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
                *mark = sv_mortalcopy(*mark);
                /* in case LEAVE wipes old return values */
     }