X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=3d0c1d1b2e62d2438afadb9cab469d4f37acc564;hb=585901d452c159529f56fbe107b0f67b21ec5bbc;hp=26e1cb8363a20ab1fd07a1c02382203be480af1a;hpb=bc177e6b66d4907a90c81f2862ce55ad78b6496f;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index 26e1cb8..3d0c1d1 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1459,7 +1459,8 @@ Perl_qerror(pTHX_ SV *err)
 	sv_catsv(PL_errors, err);
     else
 	Perl_warn(aTHX_ "%"SVf, SVfARG(err));
-    ++PL_error_count;
+    if (PL_parser)
+	++PL_parser->error_count;
 }
 
 OP *
@@ -2736,7 +2737,6 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
     I32 gimme = G_VOID;
     I32 optype;
     OP dummy;
-    OP *rop;
     char tbuf[TYPE_DIGITS(long) + 12 + 10];
     char *tmpbuf = tbuf;
     char *safestr;
@@ -2745,7 +2745,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
     STRLEN len;
 
     ENTER;
-    lex_start(sv);
+    lex_start(sv, NULL, FALSE);
     SAVETMPS;
     /* switch to eval mode */
 
@@ -2794,9 +2794,9 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
     PUSHEVAL(cx, 0, NULL);
 
     if (runtime)
-	rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
+	(void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
     else
-	rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
+	(void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
     POPBLOCK(cx,PL_curpm);
     POPEVAL(cx);
 
@@ -2814,7 +2814,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
     PERL_UNUSED_VAR(newsp);
     PERL_UNUSED_VAR(optype);
 
-    return rop;
+    return PL_eval_start;
 }
 
 
@@ -2863,9 +2863,12 @@ Perl_find_runcv(pTHX_ U32 *db_seqp)
  * In the last case, startop is non-null, and contains the address of
  * a pointer that should be set to the just-compiled code.
  * outside is the lexically enclosing CV (if any) that invoked us.
+ * Returns a bool indicating whether the compile was successful; if so,
+ * PL_eval_start contains the first op of the compiled ocde; otherwise,
+ * pushes undef (also croaks if startop != NULL).
  */
 
-STATIC OP *
+STATIC bool
 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 {
     dVAR; dSP;
@@ -2908,7 +2911,6 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     SAVESPTR(PL_unitcheckav);
     PL_unitcheckav = newAV();
     SAVEFREESV(PL_unitcheckav);
-    SAVEI8(PL_error_count);
 
 #ifdef PERL_MAD
     SAVEBOOL(PL_madskills);
@@ -2918,14 +2920,13 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     /* try to compile it */
 
     PL_eval_root = NULL;
-    PL_error_count = 0;
     PL_curcop = &PL_compiling;
     CopARYBASE_set(PL_curcop, 0);
     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
 	PL_in_eval |= EVAL_KEEPERR;
     else
 	sv_setpvn(ERRSV,"",0);
-    if (yyparse() || PL_error_count || !PL_eval_root) {
+    if (yyparse() || PL_parser->error_count || !PL_eval_root) {
 	SV **newsp;			/* Used by POPBLOCK. */
 	PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 	I32 optype = 0;			/* Might be reset by POPEVAL. */
@@ -2949,8 +2950,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 	    const SV * const nsv = cx->blk_eval.old_namesv;
 	    (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
                           &PL_sv_undef, 0);
-	    DIE(aTHX_ "%sCompilation failed in require",
-		*msg ? msg : "Unknown error\n");
+	    Perl_croak(aTHX_ "%sCompilation failed in require",
+		       *msg ? msg : "Unknown error\n");
 	}
 	else if (startop) {
 	    POPBLOCK(cx,PL_curpm);
@@ -2964,7 +2965,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 	    }
 	}
 	PERL_UNUSED_VAR(newsp);
-	RETPUSHUNDEF;
+	PUSHs(&PL_sv_undef);
+	PUTBACK;
+	return FALSE;
     }
     CopLINE_set(&PL_compiling, 0);
     if (startop) {
@@ -3011,7 +3014,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     PL_op = saveop;			/* The caller may need it. */
     PL_parser->lex_state = LEX_NOTPARSING;	/* $^S needs this. */
 
-    RETURNOP(PL_eval_start);
+    PUTBACK;
+    return TRUE;
 }
 
 STATIC PerlIO *
@@ -3062,6 +3066,11 @@ PP(pp_require)
     SV *sv;
     const char *name;
     STRLEN len;
+    char * unixname;
+    STRLEN unixlen;
+#ifdef VMS
+    int vms_unixname = 0;
+#endif
     const char *tryname = NULL;
     SV *namesv = NULL;
     const I32 gimme = GIMME_V;
@@ -3111,8 +3120,31 @@ PP(pp_require)
     if (!(name && len > 0 && *name))
 	DIE(aTHX_ "Null filename used");
     TAINT_PROPER("require");
+
+
+#ifdef VMS
+    /* The key in the %ENV hash is in the syntax of file passed as the argument
+     * usually this is in UNIX format, but sometimes in VMS format, which
+     * can result in a module being pulled in more than once.
+     * To prevent this, the key must be stored in UNIX format if the VMS
+     * name can be translated to UNIX.
+     */
+    if ((unixname = tounixspec(name, NULL)) != NULL) {
+	unixlen = strlen(unixname);
+	vms_unixname = 1;
+    }
+    else
+#endif
+    {
+        /* if not VMS or VMS name can not be translated to UNIX, pass it
+	 * through.
+	 */
+	unixname = (char *) name;
+	unixlen = len;
+    }
     if (PL_op->op_type == OP_REQUIRE) {
-	SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+	SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
+					  unixname, unixlen, 0);
 	if ( svp ) {
 	    if (*svp != &PL_sv_undef)
 		RETPUSHYES;
@@ -3142,8 +3174,7 @@ PP(pp_require)
 	AV * const ar = GvAVn(PL_incgv);
 	I32 i;
 #ifdef VMS
-	char *unixname;
-	if ((unixname = tounixspec(name, NULL)) != NULL)
+	if (vms_unixname)
 #endif
 	{
 	    namesv = newSV(0);
@@ -3368,20 +3399,19 @@ PP(pp_require)
     /* name is never assigned to again, so len is still strlen(name)  */
     /* Check whether a hook in @INC has already filled %INC */
     if (!hook_sv) {
-	(void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
+	(void)hv_store(GvHVn(PL_incgv),
+		       unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
     } else {
-	SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+	SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
 	if (!svp)
-	    (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
+	    (void)hv_store(GvHVn(PL_incgv),
+			   unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
     }
 
     ENTER;
     SAVETMPS;
-    lex_start(NULL);
-    SAVEGENERICSV(PL_rsfp_filters);
-    PL_rsfp_filters = NULL;
+    lex_start(NULL, tryrsfp, TRUE);
 
-    PL_rsfp = tryrsfp;
     SAVEHINTS();
     PL_hints = 0;
     SAVECOMPILEWARNINGS();
@@ -3414,7 +3444,10 @@ PP(pp_require)
     encoding = PL_encoding;
     PL_encoding = NULL;
 
-    op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
+    if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
+	op = DOCATCH(PL_eval_start);
+    else
+	op = PL_op->op_next;
 
     /* Restore encoding. */
     PL_encoding = encoding;
@@ -3433,7 +3466,7 @@ PP(pp_entereval)
     char *tmpbuf = tbuf;
     char *safestr;
     STRLEN len;
-    OP *ret;
+    bool ok;
     CV* runcv;
     U32 seq;
     HV *saved_hh = NULL;
@@ -3449,7 +3482,7 @@ PP(pp_entereval)
     TAINT_PROPER("eval");
 
     ENTER;
-    lex_start(sv);
+    lex_start(sv, NULL, FALSE);
     SAVETMPS;
 
     /* switch to eval mode */
@@ -3506,13 +3539,13 @@ PP(pp_entereval)
     if (PERLDB_LINE && PL_curstash != PL_debstash)
 	save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
     PUTBACK;
-    ret = doeval(gimme, NULL, runcv, seq);
+    ok = doeval(gimme, NULL, runcv, seq);
     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
-	&& ret != PL_op->op_next) {	/* Successive compilation. */
+	&& ok) {
 	/* Copy in anything fake and short. */
 	my_strlcpy(safestr, fakestr, fakelen);
     }
-    return DOCATCH(ret);
+    return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
 }
 
 PP(pp_leaveeval)
@@ -4519,7 +4552,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
 
     /* I was having segfault trouble under Linux 2.2.5 after a
        parse error occured.  (Had to hack around it with a test
-       for PL_error_count == 0.)  Solaris doesn't segfault --
+       for PL_parser->error_count == 0.)  Solaris doesn't segfault --
        not sure where the trouble is yet.  XXX */
 
     if (IoFMT_GV(datasv)) {