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

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

p4raw-id: //depot/perl@23843

diff --git a/embed.fnc b/embed.fnc
index 795f3fe..b3418f7 100644 (file)
--- 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 d5c5e40..f85de5e 100644 (file)
--- 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 43c4d44..dcb5594 100644 (file)
--- 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 2d04dda..e35e38b 100644 (file)
--- 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 81044c9..e66a42d 100644 (file)
--- 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 f2fa8d9..8da393e 100644 (file)
--- 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 829b655..6846775 100644 (file)
--- 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 f99ab1c..6162490 100644 (file)
--- 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 29f5436..5d861d2 100755 (executable)
--- 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";