From: Rick Delaney Date: Wed, 13 Oct 2004 12:40:18 +0000 (-0400) Subject: Re: [perl #31924] %INC caching failure-case problem X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=10ac92784f49d4a1fe54cc1ed7d05f0d3b2a2f29;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 --- 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. +The C 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 @@ -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 --- a/hv.h +++ b/hv.h @@ -318,6 +318,9 @@ C. /* 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 --- 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. +The C 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 --- 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 --- 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 --- 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";