+}
+
+GV *
+Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
+ const svtype sv_type)
+{
+ dVAR;
+ const char *name = nambeg;
+ GV *gv = NULL;
+ GV**gvp;
+ STRLEN len;
+ HV *stash = NULL;
+ const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
+ const I32 no_expand = flags & GV_NOEXPAND;
+ const I32 add = flags & ~GV_NOADD_MASK;
+ const U32 is_utf8 = flags & SVf_UTF8;
+ bool addmg = cBOOL(flags & GV_ADDMG);
+ const char *const name_end = nambeg + full_len;
+ U32 faking_it;
+
+ PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
+
+ /* If we have GV_NOTQUAL, the caller promised that
+ * there is no stash, so we can skip the check.
+ * Similarly if full_len is 0, since then we're
+ * dealing with something like *{""} or ""->foo()
+ */
+ if ((flags & GV_NOTQUAL) || !full_len) {
+ len = full_len;
+ }
+ else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
+ if (name == name_end) return gv;
+ }
+ else {
+ return NULL;
+ }
+
+ if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
+ return NULL;
+ }
+
+ /* By this point we should have a stash and a name */
+ gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
+ if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
+ if (addmg) gv = (GV *)newSV(0);
+ else return NULL;
+ }
+ else gv = *gvp, addmg = 0;
+ /* From this point on, addmg means gv has not been inserted in the
+ symtab yet. */
+
+ if (SvTYPE(gv) == SVt_PVGV) {
+ /* The GV already exists, so return it, but check if we need to do
+ * anything else with it before that.
+ */
+ if (add) {
+ /* This is the heuristic that handles if a variable triggers the
+ * 'used only once' warning. If there's already a GV in the stash
+ * with this name, then we assume that the variable has been used
+ * before and turn its MULTI flag on.
+ * It's a heuristic because it can easily be "tricked", like with
+ * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
+ * not warning about $main::foo being used just once
+ */
+ GvMULTI_on(gv);
+ gv_init_svtype(gv, sv_type);
+ /* You reach this path once the typeglob has already been created,
+ either by the same or a different sigil. If this path didn't
+ exist, then (say) referencing $! first, and %! second would
+ mean that %! was not handled correctly. */
+ if (len == 1 && stash == PL_defstash) {
+ maybe_multimagic_gv(gv, name, sv_type);
+ }
+ else if (len == 3 && sv_type == SVt_PVAV
+ && strnEQ(name, "ISA", 3)
+ && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
+ gv_magicalize_isa(gv);
+ }
+ return gv;
+ } else if (no_init) {
+ assert(!addmg);
+ return gv;
+ }
+ /* If GV_NOEXPAND is true and what we got off the stash is a ref,
+ * don't expand it to a glob. This is an optimization so that things
+ * copying constants over, like Exporter, don't have to be rewritten
+ * to take into account that you can store more than just globs in
+ * stashes.
+ */
+ else if (no_expand && SvROK(gv)) {
+ assert(!addmg);
+ return gv;
+ }
+
+ /* Adding a new symbol.
+ Unless of course there was already something non-GV here, in which case
+ we want to behave as if there was always a GV here, containing some sort
+ of subroutine.
+ Otherwise we run the risk of creating things like GvIO, which can cause
+ subtle bugs. eg the one that tripped up SQL::Translator */
+
+ faking_it = SvOK(gv);
+
+ if (add & GV_ADDWARN)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+ "Had to create %"UTF8f" unexpectedly",
+ UTF8fARG(is_utf8, name_end-nambeg, nambeg));
+ gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
+
+ if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) )
+ GvMULTI_on(gv) ;
+
+ /* First, store the gv in the symtab if we're adding magic,
+ * but only for non-empty GVs
+ */
+#define GvEMPTY(gv) !(GvAV(gv) || GvHV(gv) || GvIO(gv) \
+ || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv))))
+
+ if ( addmg && !GvEMPTY(gv) ) {
+ (void)hv_store(stash,name,len,(SV *)gv,0);
+ }
+
+ /* set up magic where warranted */
+ if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) {
+ /* See 23496c6 */
+ if (GvEMPTY(gv)) {
+ if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) {
+ /* The GV was and still is "empty", except that now
+ * it has the magic flags turned on, so we want it
+ * stored in the symtab.
+ */
+ (void)hv_store(stash,name,len,(SV *)gv,0);
+ }
+ else {
+ /* Most likely the temporary GV created above */
+ SvREFCNT_dec_NN(gv);
+ gv = NULL;
+ }
+ }
+ }
+
https://perl5.git.perl.org / perl5.git / blobdiff