More HP-UX/IA64 work

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

diff --git a/pp_ctl.c b/pp_ctl.c
index 8805316..9c4479b 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1,6 +1,6 @@
 /*    pp_ctl.c
  *
- *    Copyright (c) 1991-2001, Larry Wall
+ *    Copyright (c) 1991-2002, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -158,6 +158,7 @@ PP(pp_substcont)
     register REGEXP *rx = cx->sb_rx;
 
     rxres_restore(&cx->sb_rxres, rx);
+    PL_reg_match_utf8 = SvUTF8(cx->sb_targ) ? 1 : 0;
 
     if (cx->sb_iters++) {
        I32 saviters = cx->sb_iters;
@@ -395,7 +396,7 @@ PP(pp_formline)
            else {
                sv = &PL_sv_no;
                if (ckWARN(WARN_SYNTAX))
-                   Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
+                   Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
            }
            break;
 
@@ -895,13 +896,16 @@ PP(pp_flip)
     else {
        dTOPss;
        SV *targ = PAD_SV(PL_op->op_targ);
-       int flip;
+       int flip = 0;
 
        if (PL_op->op_private & OPpFLIP_LINENUM) {
-           struct io *gp_io;
-           flip = PL_last_in_gv
-               && (gp_io = GvIO(PL_last_in_gv))
-               && SvIV(sv) == (IV)IoLINES(gp_io);
+           if (GvIO(PL_last_in_gv)) {
+               flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
+           }
+           else {
+               GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
+               if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
+           }
        } else {
            flip = SvTRUE(sv);
        }
@@ -979,11 +983,23 @@ PP(pp_flop)
     else {
        dTOPss;
        SV *targ = PAD_SV(cUNOP->op_first->op_targ);
+       int flop = 0;
        sv_inc(targ);
-       if ((PL_op->op_private & OPpFLIP_LINENUM)
-         ? (GvIO(PL_last_in_gv)
-            && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
-         : SvTRUE(sv) ) {
+
+       if (PL_op->op_private & OPpFLIP_LINENUM) {
+           if (GvIO(PL_last_in_gv)) {
+               flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
+           }
+           else {
+               GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
+               if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
+           }
+       }
+       else {
+           flop = SvTRUE(sv);
+       }
+
+       if (flop) {
            sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
            sv_catpv(targ, "E0");
        }
@@ -1006,27 +1022,27 @@ S_dopoptolabel(pTHX_ char *label)
        switch (CxTYPE(cx)) {
        case CXt_SUBST:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
+               Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
                        OP_NAME(PL_op));
            break;
        case CXt_SUB:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
+               Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
                        OP_NAME(PL_op));
            break;
        case CXt_FORMAT:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
+               Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
                        OP_NAME(PL_op));
            break;
        case CXt_EVAL:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
+               Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
                        OP_NAME(PL_op));
            break;
        case CXt_NULL:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
+               Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
                        OP_NAME(PL_op));
            return -1;
        case CXt_LOOP:
@@ -1141,27 +1157,27 @@ S_dopoptoloop(pTHX_ I32 startingblock)
        switch (CxTYPE(cx)) {
        case CXt_SUBST:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
+               Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
                        OP_NAME(PL_op));
            break;
        case CXt_SUB:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
+               Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
                        OP_NAME(PL_op));
            break;
        case CXt_FORMAT:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
+               Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
                        OP_NAME(PL_op));
            break;
        case CXt_EVAL:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
+               Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
                        OP_NAME(PL_op));
            break;
        case CXt_NULL:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
+               Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
                        OP_NAME(PL_op));
            return -1;
        case CXt_LOOP:
@@ -1224,6 +1240,9 @@ OP *
 Perl_die_where(pTHX_ char *message, STRLEN msglen)
 {
     STRLEN n_a;
+    IO *io;
+    MAGIC *mg;
+
     if (PL_in_eval) {
        I32 cxix;
        register PERL_CONTEXT *cx;
@@ -1249,7 +1268,7 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
                    sv_catpvn(err, message, msglen);
                    if (ckWARN(WARN_MISC)) {
                        STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
-                       Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
+                       Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
                    }
                }
            }
@@ -1303,7 +1322,19 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
     }
     if (!message)
        message = SvPVx(ERRSV, msglen);
-    {
+
+    /* if STDERR is tied, print to it instead */
+    if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
+       && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
+       dSP; ENTER;
+       PUSHMARK(SP);
+       XPUSHs(SvTIED_obj((SV*)io, mg));
+       XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
+       PUTBACK;
+       call_method("PRINT", G_SCALAR);
+       LEAVE;
+    }
+    else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
        int e = errno;
@@ -1414,7 +1445,7 @@ PP(pp_caller)
        PUSHs(&PL_sv_undef);
     else
        PUSHs(sv_2mortal(newSVpv(stashname, 0)));
-    PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
+    PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
     if (!MAXARG)
        RETURN;
@@ -2855,7 +2886,7 @@ PP(pp_require)
     OP *op;
 
     sv = POPs;
-    if (SvNIOKp(sv)) {
+    if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
        if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
            UV rev = 0, ver = 0, sver = 0;
            STRLEN len;
@@ -2882,7 +2913,7 @@ PP(pp_require)
                    PERL_VERSION, PERL_SUBVERSION);
            }
            if (ckWARN(WARN_PORTABLE))
-               Perl_warner(aTHX_ WARN_PORTABLE,
+               Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
                         "v-string in use/require non-portable");
            RETPUSHYES;
        }
@@ -3124,7 +3155,7 @@ PP(pp_require)
                SvREFCNT_dec(dirmsgsv);
                msgstr = SvPV_nolen(msg);
            }
-           DIE(aTHX_ "Can't locate %s", msgstr);
+           DIE(aTHX_ "Can't locate file %s", msgstr);
        }
 
        RETPUSHUNDEF;