Re: [perl #31924] %INC caching failure-case problem

Message-ID: <20041013164018.GA32174@biff.bort.ca>

p4raw-id: //depot/perl@23843

9 files changed, 87 insertions, 13 deletions

diff --git a/embed.fnc b/embed.fnc
index 795f3fe6c5..b3418f7734 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -271,6 +271,7 @@ Apd	|SV*	|hv_delete_ent	|HV* tb|SV* key|I32 flags|U32 hash
 Apd	|bool	|hv_exists	|HV* tb|const char* key|I32 klen
 Apd	|bool	|hv_exists_ent	|HV* tb|SV* key|U32 hash
 Apd	|SV**	|hv_fetch	|HV* tb|const char* key|I32 klen|I32 lval
+ApMd	|SV**	|hv_fetch_flags	|HV* tb|const char* key|I32 klen|I32 lval|I32 flags
 Apd	|HE*	|hv_fetch_ent	|HV* tb|SV* key|I32 lval|U32 hash
 Ap	|void	|hv_free_ent	|HV* hv|HE* entry
 Apd	|I32	|hv_iterinit	|HV* tb
diff --git a/embed.h b/embed.h
index d5c5e4018a..f85de5e643 100644
--- a/embed.h
+++ b/embed.h
@@ -327,6 +327,7 @@
 #define hv_exists		Perl_hv_exists
 #define hv_exists_ent		Perl_hv_exists_ent
 #define hv_fetch		Perl_hv_fetch
+#define hv_fetch_flags		Perl_hv_fetch_flags
 #define hv_fetch_ent		Perl_hv_fetch_ent
 #define hv_free_ent		Perl_hv_free_ent
 #define hv_iterinit		Perl_hv_iterinit
@@ -2934,6 +2935,7 @@
 #define hv_exists(a,b,c)	Perl_hv_exists(aTHX_ a,b,c)
 #define hv_exists_ent(a,b,c)	Perl_hv_exists_ent(aTHX_ a,b,c)
 #define hv_fetch(a,b,c,d)	Perl_hv_fetch(aTHX_ a,b,c,d)
+#define hv_fetch_flags(a,b,c,d,e)	Perl_hv_fetch_flags(aTHX_ a,b,c,d,e)
 #define hv_fetch_ent(a,b,c,d)	Perl_hv_fetch_ent(aTHX_ a,b,c,d)
 #define hv_free_ent(a,b)	Perl_hv_free_ent(aTHX_ a,b)
 #define hv_iterinit(a)		Perl_hv_iterinit(aTHX_ a)
diff --git a/global.sym b/global.sym
index 43c4d4440a..dcb5594c6f 100644
--- a/global.sym
+++ b/global.sym
@@ -145,6 +145,7 @@ Perl_hv_delete_ent
 Perl_hv_exists
 Perl_hv_exists_ent
 Perl_hv_fetch
+Perl_hv_fetch_flags
 Perl_hv_fetch_ent
 Perl_hv_free_ent
 Perl_hv_iterinit
diff --git a/hv.c b/hv.c
index 2d04dda6ac..e35e38bd0d 100644
--- a/hv.c
+++ b/hv.c
@@ -186,6 +186,7 @@ S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
 #define HV_FETCH_ISEXISTS  0x02
 #define HV_FETCH_LVALUE    0x04
 #define HV_FETCH_JUST_SV   0x08
+#define HV_FETCH_PLACEHOLDER   0x10
 
 /*
 =for apidoc hv_store
@@ -337,6 +338,46 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
 }
 
 /*
+=for apidoc hv_fetch_flags
+
+Returns the SV which corresponds to the specified key in the hash.
+See C<hv_fetch>.
+The C<flags> value will normally be zero; if HV_FETCH_WANTPLACEHOLDERS is
+set then placeholders keys (for restricted hashes) will be returned in addition
+to normal keys. By default placeholders are automatically skipped over.
+Currently a placeholder is implemented with a value that is
+C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
+restricted hashes may change.
+
+=cut
+*/
+
+SV**
+Perl_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval, 
+		    I32 flags)
+{
+    HE *hek;
+    STRLEN klen;
+    int common_flags;
+
+    if (klen_i32 < 0) {
+	klen = -klen_i32;
+	common_flags = HVhek_UTF8;
+    } else {
+	klen = klen_i32;
+	common_flags = 0;
+    }
+    hek = hv_fetch_common (hv, NULL, key, klen, common_flags,
+			   ((flags & HV_FETCH_WANTPLACEHOLDERS) 
+				? HV_FETCH_PLACEHOLDER 
+				: 0)
+			    | HV_FETCH_JUST_SV 
+			    | (lval ? HV_FETCH_LVALUE : 0),
+			   Nullsv, 0);
+    return hek ? &HeVAL(hek) : NULL;
+}
+
+/*
 =for apidoc hv_exists_ent
 
 Returns a boolean indicating whether the specified hash key exists. C<hash>
@@ -693,7 +734,9 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 		SvREFCNT_dec(HeVAL(entry));
 		HeVAL(entry) = val;
 	    }
-	} else if (HeVAL(entry) == &PL_sv_placeholder) {
+	} else if (HeVAL(entry) == &PL_sv_placeholder 
+		    && !(action & HV_FETCH_PLACEHOLDER)) 
+	{
 	    /* if we find a placeholder, we pretend we haven't found
 	       anything */
 	    break;
diff --git a/hv.h b/hv.h
index 81044c9097..e66a42d9cf 100644
--- a/hv.h
+++ b/hv.h
@@ -318,6 +318,9 @@ C<SV*>.
 /* Flags for hv_iternext_flags.  */
 #define HV_ITERNEXT_WANTPLACEHOLDERS	0x01	/* Don't skip placeholders.  */
 
+/* Flags for hv_fetch_flags.  */
+#define HV_FETCH_WANTPLACEHOLDERS	0x01	/* Don't skip placeholders.  */
+
 /* available as a function in hv.c */
 #define Perl_sharepvn(sv, len, hash) HEK_KEY(share_hek(sv, len, hash))
 #define sharepvn(sv, len, hash)	     Perl_sharepvn(sv, len, hash)
diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index f2fa8d9b62..8da393e4e9 100644
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -1196,6 +1196,25 @@ information on how to use this function on tied hashes.
 =for hackers
 Found in file hv.c
 
+=item hv_fetch_flags
+
+Returns the SV which corresponds to the specified key in the hash.
+See C<hv_fetch>.
+The C<flags> value will normally be zero; if HV_FETCH_WANTPLACEHOLDERS is
+set then placeholders keys (for restricted hashes) will be returned in addition
+to normal keys. By default placeholders are automatically skipped over.
+Currently a placeholder is implemented with a value that is
+C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
+restricted hashes may change.
+
+NOTE: this function is experimental and may change or be
+removed without notice.
+
+	SV**	hv_fetch_flags(HV* tb, const char* key, I32 klen, I32 lval, I32 flags)
+
+=for hackers
+Found in file hv.c
+
 =item hv_iterinit
 
 Prepares a starting point to traverse a hash table.  Returns the number of
diff --git a/pp_ctl.c b/pp_ctl.c
index 829b655f1d..684677520d 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1469,7 +1469,7 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
 		char* msg = SvPVx(ERRSV, n_a);
                SV *nsv = cx->blk_eval.old_namesv;
                (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
-                               &PL_sv_undef, 0);
+                               &PL_sv_placeholder, 0);
 		DIE(aTHX_ "%sCompilation failed in require",
 		    *msg ? msg : "Unknown error\n");
 	    }
@@ -2941,7 +2941,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 	    char* msg = SvPVx(ERRSV, n_a);
            SV *nsv = cx->blk_eval.old_namesv;
            (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
-                          &PL_sv_undef, 0);
+                          &PL_sv_placeholder, 0);
 	    DIE(aTHX_ "%sCompilation failed in require",
 		*msg ? msg : "Unknown error\n");
 	}
@@ -3083,8 +3083,10 @@ PP(pp_require)
 	DIE(aTHX_ "Null filename used");
     TAINT_PROPER("require");
     if (PL_op->op_type == OP_REQUIRE &&
-       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
-       if (*svp != &PL_sv_undef)
+       (svp = hv_fetch_flags(GvHVn(PL_incgv), name, len, 0,
+		       HV_FETCH_WANTPLACEHOLDERS)))
+    {
+       if (*svp != &PL_sv_placeholder)
            RETPUSHYES;
        else
            DIE(aTHX_ "Compilation failed in require");
diff --git a/proto.h b/proto.h
index f99ab1c8c4..616249013c 100644
--- a/proto.h
+++ b/proto.h
@@ -250,6 +250,7 @@ PERL_CALLCONV SV*	Perl_hv_delete_ent(pTHX_ HV* tb, SV* key, I32 flags, U32 hash)
 PERL_CALLCONV bool	Perl_hv_exists(pTHX_ HV* tb, const char* key, I32 klen);
 PERL_CALLCONV bool	Perl_hv_exists_ent(pTHX_ HV* tb, SV* key, U32 hash);
 PERL_CALLCONV SV**	Perl_hv_fetch(pTHX_ HV* tb, const char* key, I32 klen, I32 lval);
+PERL_CALLCONV SV**	Perl_hv_fetch_flags(pTHX_ HV* tb, const char* key, I32 klen, I32 lval, I32 flags);
 PERL_CALLCONV HE*	Perl_hv_fetch_ent(pTHX_ HV* tb, SV* key, I32 lval, U32 hash);
 PERL_CALLCONV void	Perl_hv_free_ent(pTHX_ HV* hv, HE* entry);
 PERL_CALLCONV I32	Perl_hv_iterinit(pTHX_ HV* tb);
diff --git a/t/comp/require.t b/t/comp/require.t
index 29f5436df7..5d861d24ec 100755
--- a/t/comp/require.t
+++ b/t/comp/require.t
@@ -11,8 +11,9 @@ $i = 1;
 
 my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
 my $Is_UTF8   = (${^OPEN} || "") =~ /:utf8/;
-my $total_tests = 44;
-if ($Is_EBCDIC || $Is_UTF8) { $total_tests = 41; }
+my $total_tests = 43;
+my $ebcdic_utf8_skips = 3;
+if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= $ebcdic_utf8_skips; }
 print "1..$total_tests\n";
 
 sub do_require {
@@ -122,8 +123,6 @@ for my $expected_compile (1,0) {
     print "ok ",$i++,"\n";
     print "not " unless -e $flag_file xor $expected_compile;
     print "ok ",$i++,"\n";
-    print "not " unless exists $INC{'bleah.pm'};
-    print "ok ",$i++,"\n";
 }
 
 # compile-time failure in require
@@ -133,9 +132,6 @@ do_require "1)\n";
 print "# $@\nnot " unless $@ =~ /(syntax|parse) error/mi;
 print "ok ",$i++,"\n";
 
-# previous failure cached in %INC
-print "not " unless exists $INC{'bleah.pm'};
-print "ok ",$i++,"\n";
 write_file($flag_file, 1);
 write_file('bleah.pm', "unlink '$flag_file'; 1");
 print "# $@\nnot " if eval { require 'bleah.pm' };
@@ -144,13 +140,19 @@ print "# $@\nnot " unless $@ =~ /Compilation failed/i;
 print "ok ",$i++,"\n";
 print "not " unless -e $flag_file;
 print "ok ",$i++,"\n";
-print "not " unless exists $INC{'bleah.pm'};
+# [perl #31924]
+eval { $INC{'bleah.pm'} = 'bleah.pm' };
+print "# $@\nnot " if $@;
+print "ok ",$i++,"\n";
+print "not " unless $INC{'bleah.pm'} eq 'bleah.pm';
 print "ok ",$i++,"\n";
 
 # successful require
 do_require "1";
 print "# $@\nnot " if $@;
 print "ok ",$i++,"\n";
+print "not " unless $INC{'bleah.pm'} eq 'bleah.pm';
+print "ok ",$i++,"\n";
 
 # do FILE shouldn't see any outside lexicals
 my $x = "ok $i\n";