Patch by Gerard Goosen to avoid building man pages for extensions

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

diff --git a/pp_ctl.c b/pp_ctl.c
index c6ee3f7..3d0c1d1 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2737,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;
@@ -2795,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);
 
@@ -2815,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;
 }
 
 
@@ -2864,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;
@@ -2948,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);
@@ -2963,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) {
@@ -3010,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 *
@@ -3061,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;
@@ -3110,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;
@@ -3141,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);
@@ -3367,11 +3399,13 @@ 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;
@@ -3410,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;
@@ -3429,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;
@@ -3502,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)