_60 & _04 - Add WRITE & CLOSE to TIEHANDLE

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

diff --git a/pp_ctl.c b/pp_ctl.c
index 9590271..9753fcf 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -86,10 +86,12 @@ PP(pp_regcomp) {
     else {
        t = SvPV(tmpstr, len);
 
-       /* JMR: Check against the last compiled regexp */
-       if ( ! pm->op_pmregexp  || ! pm->op_pmregexp->precomp
-           || strnNE(pm->op_pmregexp->precomp, t, len) 
-           || pm->op_pmregexp->precomp[len]) {
+       /* JMR: Check against the last compiled regexp
+          To know for sure, we'd need the length of precomp.
+          But we don't have it, so we must ... take a guess. */
+       if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
+           memNE(pm->op_pmregexp->precomp, t, len + 1))
+       {
            if (pm->op_pmregexp) {
                ReREFCNT_dec(pm->op_pmregexp);
                pm->op_pmregexp = Null(REGEXP*);        /* crucial if regcomp aborts */
@@ -547,7 +549,7 @@ PP(pp_grepstart)
     SAVETMPS;
 #ifdef USE_THREADS
     /* SAVE_DEFSV does *not* suffice here */
-    save_sptr(av_fetch(thr->threadsv, find_threadsv("_"), FALSE));
+    save_sptr(&THREADSV(0));
 #else
     SAVESPTR(GvSV(defgv));
 #endif /* USE_THREADS */
@@ -1009,7 +1011,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+1, block_type[cx->cx_type]));
+                             (long) cxstack_ix, block_type[cx->cx_type]));
        /* Note: we don't need to restore the base context info till the end. */
        switch (cx->cx_type) {
        case CXt_SUBST:
@@ -1132,6 +1134,7 @@ PP(pp_caller)
     register PERL_CONTEXT *cx;
     I32 dbcxix;
     I32 gimme;
+    HV *hv;
     SV *sv;
     I32 count = 0;
 
@@ -1161,14 +1164,22 @@ PP(pp_caller)
     }
 
     if (GIMME != G_ARRAY) {
-       dTARGET;
-
-       sv_setpv(TARG, HvNAME(cx->blk_oldcop->cop_stash));
-       PUSHs(TARG);
+       hv = cx->blk_oldcop->cop_stash;
+       if (!hv)
+           PUSHs(&sv_undef);
+       else {
+           dTARGET;
+           sv_setpv(TARG, HvNAME(hv));
+           PUSHs(TARG);
+       }
        RETURN;
     }
 
-    PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0)));
+    hv = cx->blk_oldcop->cop_stash;
+    if (!hv)
+       PUSHs(&sv_undef);
+    else
+       PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
     PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
     if (!MAXARG)
@@ -1336,8 +1347,9 @@ PP(pp_enteriter)
        SAVESPTR(*svp);
     }
     else {
-       svp = &GvSV((GV*)POPs);                 /* symbol table variable */
-       SAVESPTR(*svp);
+       GV *gv = (GV*)POPs;
+       (void)save_scalar(gv);
+       svp = &GvSV(gv);                        /* symbol table variable */
     }
 
     ENTER;
@@ -1710,8 +1722,11 @@ PP(pp_goto)
            if (cxix < cxstack_ix)
                dounwind(cxix);
            TOPBLOCK(cx);
+           if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) 
+               DIE("Can't goto subroutine from an eval-string");
            mark = stack_sp;
-           if (cx->blk_sub.hasargs) {   /* put @_ back onto stack */
+           if (cx->cx_type == CXt_SUB &&
+               cx->blk_sub.hasargs) {   /* put @_ back onto stack */
                AV* av = cx->blk_sub.argarray;
                
                items = AvFILLp(av) + 1;
@@ -1726,7 +1741,8 @@ PP(pp_goto)
                AvREAL_off(av);
                av_clear(av);
            }
-           if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
+           if (cx->cx_type == CXt_SUB &&
+               !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
                SvREFCNT_dec(cx->blk_sub.cv);
            oldsave = scopestack[scopestack_ix - 1];
            LEAVE_SCOPE(oldsave);
@@ -1756,6 +1772,12 @@ PP(pp_goto)
            else {
                AV* padlist = CvPADLIST(cv);
                SV** svp = AvARRAY(padlist);
+               if (cx->cx_type == CXt_EVAL) {
+                   in_eval = cx->blk_eval.old_in_eval;
+                   eval_root = cx->blk_eval.old_eval_root;
+                   cx->cx_type = CXt_SUB;
+                   cx->blk_sub.hasargs = 0;
+               }
                cx->blk_sub.cv = cv;
                cx->blk_sub.olddepth = CvDEPTH(cv);
                CvDEPTH(cv)++;
@@ -2162,6 +2184,7 @@ doeval(int gimme, OP** startop)
     HV *newstash;
     CV *caller;
     AV* comppadlist;
+    I32 i;
 
     in_eval = 1;
 
@@ -2178,6 +2201,16 @@ doeval(int gimme, OP** startop)
     SAVEI32(max_intro_pending);
 
     caller = compcv;
+    for (i = cxstack_ix - 1; i >= 0; i--) {
+       PERL_CONTEXT *cx = &cxstack[i];
+       if (cx->cx_type == CXt_EVAL)
+           break;
+       else if (cx->cx_type == CXt_SUB) {
+           caller = cx->blk_sub.cv;
+           break;
+       }
+    }
+
     SAVESPTR(compcv);
     compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)compcv, SVt_PVCV);
@@ -2325,6 +2358,7 @@ PP(pp_require)
     register PERL_CONTEXT *cx;
     SV *sv;
     char *name;
+    STRLEN len;
     char *tryname;
     SV *namesv = Nullsv;
     SV** svp;
@@ -2339,12 +2373,12 @@ PP(pp_require)
                SvPV(sv,na),patchlevel);
        RETPUSHYES;
     }
-    name = SvPV(sv, na);
-    if (!*name)
+    name = SvPV(sv, len);
+    if (!(name && len > 0 && *name))
        DIE("Null filename used");
     TAINT_PROPER("require");
     if (op->op_type == OP_REQUIRE &&
-      (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) &&
+      (svp = hv_fetch(GvHVn(incgv), name, len, 0)) &&
       *svp != &sv_undef)
        RETPUSHYES;
 
@@ -2606,6 +2640,7 @@ PP(pp_leaveeval)
     assert(CvDEPTH(compcv) == 1);
 #endif
     CvDEPTH(compcv) = 0;
+    lex_end();
 
     if (optype == OP_REQUIRE &&
        !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp))
@@ -2614,13 +2649,13 @@ PP(pp_leaveeval)
        char *name = cx->blk_eval.old_name;
        (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
        retop = die("%s did not return a true value", name);
+       /* die_where() did LEAVE, or we won't be here */
+    }
+    else {
+       LEAVE;
+       if (!(save_flags & OPf_SPECIAL))
+           sv_setpv(ERRSV,"");
     }
-
-    lex_end();
-    LEAVE;
-
-    if (!(save_flags & OPf_SPECIAL))
-       sv_setpv(ERRSV,"");
 
     RETURNOP(retop);
 }