INSTALL patches

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

diff --git a/pp_hot.c b/pp_hot.c
index 27af29d..f48e98f 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1,6 +1,6 @@
 /*    pp_hot.c
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-1999, 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.
@@ -733,16 +733,10 @@ PP(pp_aassign)
            }
            break;
        default:
-           if (SvTHINKFIRST(sv)) {
-               if (SvREADONLY(sv) && PL_curcop != &PL_compiling) {
-                   if (!SvIMMORTAL(sv))
-                       DIE(PL_no_modify);
-                   if (relem <= lastrelem)
-                       relem++;
-                   break;
-               }
-               if (SvROK(sv))
-                   sv_unref(sv);
+           if (SvIMMORTAL(sv)) {
+               if (relem <= lastrelem)
+                   relem++;
+               break;
            }
            if (relem <= lastrelem) {
                sv_setsv(sv, *relem);
@@ -855,7 +849,7 @@ PP(pp_match)
     register char *s;
     char *strend;
     I32 global;
-    I32 r_flags;
+    I32 r_flags = 0;
     char *truebase;
     register REGEXP *rx = pm->op_pmregexp;
     bool rxtainted;
@@ -904,14 +898,18 @@ PP(pp_match)
            if (mg && mg->mg_len >= 0) {
                if (!(rx->reganch & ROPT_GPOS_SEEN))
                    rx->endp[0] = rx->startp[0] = s + mg->mg_len; 
+               else if (rx->reganch & ROPT_ANCH_GPOS) {
+                   r_flags |= REXEC_IGNOREPOS;
+                   rx->endp[0] = rx->startp[0] = s + mg->mg_len; 
+               }
                minmatch = (mg->mg_flags & MGf_MINMATCH);
                update_minmatch = 0;
            }
        }
     }
-    r_flags = ((gimme != G_ARRAY && !global && rx->nparens)
-               || SvTEMP(TARG) || PL_sawampersand)
-               ? REXEC_COPY_STR : 0;
+    if ((gimme != G_ARRAY && !global && rx->nparens)
+           || SvTEMP(TARG) || PL_sawampersand)
+       r_flags |= REXEC_COPY_STR;
     if (SvSCREAM(TARG) && rx->check_substr
        && SvTYPE(rx->check_substr) == SVt_PVBM
        && SvVALID(rx->check_substr)) 
@@ -1297,8 +1295,18 @@ do_readline(void)
        sv = sv_2mortal(NEWSV(57, 80));
        offset = 0;
     }
+
+/* flip-flop EOF state for a snarfed empty file */
+#define SNARF_EOF(gimme,rs,io,sv) \
+    ((gimme != G_SCALAR || SvCUR(sv)                                   \
+      || (IoFLAGS(io) & IOf_NOLINE) || IoLINES(io) || !RsSNARF(rs))    \
+       ? ((IoFLAGS(io) &= ~IOf_NOLINE), TRUE)                          \
+       : ((IoFLAGS(io) |= IOf_NOLINE), FALSE))
+
     for (;;) {
-       if (!sv_gets(sv, fp, offset)) {
+       if (!sv_gets(sv, fp, offset)
+           && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
+       {
            PerlIO_clearerr(fp);
            if (IoFLAGS(io) & IOf_ARGV) {
                fp = nextargv(PL_last_in_gv);
@@ -2085,16 +2093,15 @@ PP(pp_entersub)
     case SVt_PVGV:
        if (!(cv = GvCVu((GV*)sv)))
            cv = sv_2cv(sv, &stash, &gv, TRUE);
-       break;
+       if (cv)
+           break;
+       DIE("Not a CODE reference");
     }
 
     ENTER;
     SAVETMPS;
 
   retry:
-    if (!cv)
-       DIE("Not a CODE reference");
-
     if (!CvROOT(cv) && !CvXSUB(cv)) {
        GV* autogv;
        SV* sub_name;
@@ -2102,29 +2109,34 @@ PP(pp_entersub)
        /* anonymous or undef'd function leaves us no recourse */
        if (CvANON(cv) || !(gv = CvGV(cv)))
            DIE("Undefined subroutine called");
+
        /* autoloaded stub? */
        if (cv != GvCV(gv)) {
            cv = GvCV(gv);
-           goto retry;
        }
        /* should call AUTOLOAD now? */
-       if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
+       else if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
                                   FALSE)))
        {
            cv = GvCV(autogv);
-           goto retry;
        }
        /* sorry */
-       sub_name = sv_newmortal();
-       gv_efullname3(sub_name, gv, Nullch);
-       DIE("Undefined subroutine &%s called", SvPVX(sub_name));
+       else {
+           sub_name = sv_newmortal();
+           gv_efullname3(sub_name, gv, Nullch);
+           DIE("Undefined subroutine &%s called", SvPVX(sub_name));
+       }
+       if (!cv)
+           DIE("Not a CODE reference");
+       goto retry;
     }
 
     gimme = GIMME_V;
-    if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv))
+    if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
        cv = get_db_sub(&sv, cv);
-    if (!cv)
-       DIE("No DBsub routine");
+       if (!cv)
+           DIE("No DBsub routine");
+    }
 
 #ifdef USE_THREADS
     /*
@@ -2141,8 +2153,13 @@ PP(pp_entersub)
            if (SP > PL_stack_base + TOPMARK)
                sv = *(PL_stack_base + TOPMARK + 1);
            else {
-               MUTEX_UNLOCK(CvMUTEXP(cv));
-               croak("no argument for locked method call");
+               AV *av = (AV*)PL_curpad[0];
+               if (hasargs || !av || AvFILLp(av) < 0
+                   || !(sv = AvARRAY(av)[0]))
+               {
+                   MUTEX_UNLOCK(CvMUTEXP(cv));
+                   croak("no argument for locked method call");
+               }
            }
            if (SvROK(sv))
                sv = SvRV(sv);
@@ -2255,6 +2272,7 @@ PP(pp_entersub)
 #endif /* USE_THREADS */
 
     if (CvXSUB(cv)) {
+#ifdef PERL_XSUB_OLDSTYLE
        if (CvOLDSTYLE(cv)) {
            I32 (*fp3)_((int,int,int));
            dMARK;
@@ -2271,7 +2289,9 @@ PP(pp_entersub)
                           items);
            PL_stack_sp = PL_stack_base + items;
        }
-       else {
+       else
+#endif /* PERL_XSUB_OLDSTYLE */
+       {
            I32 markix = TOPMARK;
 
            PUTBACK;
@@ -2297,9 +2317,8 @@ PP(pp_entersub)
                    PUTBACK ;               
                }
            }
-           if (PL_curcopdb) {          /* We assume that the first
-                                          XSUB in &DB::sub is the
-                                          called one. */
+           /* We assume first XSUB in &DB::sub is the called one. */
+           if (PL_curcopdb) {
                SAVESPTR(PL_curcop);
                PL_curcop = PL_curcopdb;
                PL_curcopdb = NULL;