gv.c

   1 /*    gv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
  13  * of your inquisitiveness, I shall spend all the rest of my days in answering
  14  * you.  What more do you want to know?'
  15  *   'The names of all the stars, and of all living things, and the whole
  16  * history of Middle-earth and Over-heaven and of the Sundering Seas,'
  17  * laughed Pippin.
  18  *
  19  *     [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
  20  */
  21
  22 /*
  23 =head1 GV Functions
  24 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
  25 It is a structure that holds a pointer to a scalar, an array, a hash etc,
  26 corresponding to $foo, @foo, %foo.
  27
  28 GVs are usually found as values in stashes (symbol table hashes) where
  29 Perl stores its global variables.
  30
  31 =cut
  32 */
  33
  34 #include "EXTERN.h"
  35 #define PERL_IN_GV_C
  36 #include "perl.h"
  37 #include "overload.inc"
  38 #include "keywords.h"
  39 #include "feature.h"
  40
  41 static const char S_autoload[] = "AUTOLOAD";
  42 #define S_autolen (sizeof("AUTOLOAD")-1)
  43
  44 GV *
  45 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
  46 {
  47     SV **where;
  48
  49     if (
  50         !gv
  51      || (
  52             SvTYPE((const SV *)gv) != SVt_PVGV
  53          && SvTYPE((const SV *)gv) != SVt_PVLV
  54         )
  55     ) {
  56         const char *what;
  57         if (type == SVt_PVIO) {
  58             /*
  59              * if it walks like a dirhandle, then let's assume that
  60              * this is a dirhandle.
  61              */
  62             what = OP_IS_DIRHOP(PL_op->op_type) ?
  63                 "dirhandle" : "filehandle";
  64         } else if (type == SVt_PVHV) {
  65             what = "hash";
  66         } else {
  67             what = type == SVt_PVAV ? "array" : "scalar";
  68         }
  69         /* diag_listed_as: Bad symbol for filehandle */
  70         Perl_croak(aTHX_ "Bad symbol for %s", what);
  71     }
  72
  73     if (type == SVt_PVHV) {
  74         where = (SV **)&GvHV(gv);
  75     } else if (type == SVt_PVAV) {
  76         where = (SV **)&GvAV(gv);
  77     } else if (type == SVt_PVIO) {
  78         where = (SV **)&GvIOp(gv);
  79     } else {
  80         where = &GvSV(gv);
  81     }
  82
  83     if (!*where)
  84     {
  85         *where = newSV_type(type);
  86             if (type == SVt_PVAV && GvNAMELEN(gv) == 3
  87              && strEQs(GvNAME(gv), "ISA"))
  88             sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
  89     }
  90     return gv;
  91 }
  92
  93 GV *
  94 Perl_gv_fetchfile(pTHX_ const char *name)
  95 {
  96     PERL_ARGS_ASSERT_GV_FETCHFILE;
  97     return gv_fetchfile_flags(name, strlen(name), 0);
  98 }
  99
 100 GV *
 101 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
 102                         const U32 flags)
 103 {
 104     char smallbuf[128];
 105     char *tmpbuf;
 106     const STRLEN tmplen = namelen + 2;
 107     GV *gv;
 108
 109     PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
 110     PERL_UNUSED_ARG(flags);
 111
 112     if (!PL_defstash)
 113         return NULL;
 114
 115     if (tmplen <= sizeof smallbuf)
 116         tmpbuf = smallbuf;
 117     else
 118         Newx(tmpbuf, tmplen, char);
 119     /* This is where the debugger's %{"::_<$filename"} hash is created */
 120     tmpbuf[0] = '_';
 121     tmpbuf[1] = '<';
 122     memcpy(tmpbuf + 2, name, namelen);
 123     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
 124     if (!isGV(gv)) {
 125         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
 126 #ifdef PERL_DONT_CREATE_GVSV
 127         GvSV(gv) = newSVpvn(name, namelen);
 128 #else
 129         sv_setpvn(GvSV(gv), name, namelen);
 130 #endif
 131     }
 132     if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv))
 133             hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
 134     if (tmpbuf != smallbuf)
 135         Safefree(tmpbuf);
 136     return gv;
 137 }
 138
 139 /*
 140 =for apidoc gv_const_sv
 141
 142 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
 143 inlining, or C<gv> is a placeholder reference that would be promoted to such
 144 a typeglob, then returns the value returned by the sub.  Otherwise, returns
 145 C<NULL>.
 146
 147 =cut
 148 */
 149
 150 SV *
 151 Perl_gv_const_sv(pTHX_ GV *gv)
 152 {
 153     PERL_ARGS_ASSERT_GV_CONST_SV;
 154     PERL_UNUSED_CONTEXT;
 155
 156     if (SvTYPE(gv) == SVt_PVGV)
 157         return cv_const_sv(GvCVu(gv));
 158     return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL;
 159 }
 160
 161 GP *
 162 Perl_newGP(pTHX_ GV *const gv)
 163 {
 164     GP *gp;
 165     U32 hash;
 166     const char *file;
 167     STRLEN len;
 168 #ifndef USE_ITHREADS
 169     GV *filegv;
 170 #endif
 171     dVAR;
 172
 173     PERL_ARGS_ASSERT_NEWGP;
 174     Newxz(gp, 1, GP);
 175     gp->gp_egv = gv; /* allow compiler to reuse gv after this */
 176 #ifndef PERL_DONT_CREATE_GVSV
 177     gp->gp_sv = newSV(0);
 178 #endif
 179
 180     /* PL_curcop may be null here.  E.g.,
 181         INIT { bless {} and exit }
 182        frees INIT before looking up DESTROY (and creating *DESTROY)
 183     */
 184     if (PL_curcop) {
 185         gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
 186 #ifdef USE_ITHREADS
 187         if (CopFILE(PL_curcop)) {
 188             file = CopFILE(PL_curcop);
 189             len = strlen(file);
 190         }
 191 #else
 192         filegv = CopFILEGV(PL_curcop);
 193         if (filegv) {
 194             file = GvNAME(filegv)+2;
 195             len = GvNAMELEN(filegv)-2;
 196         }
 197 #endif
 198         else goto no_file;
 199     }
 200     else {
 201         no_file:
 202         file = "";
 203         len = 0;
 204     }
 205
 206     PERL_HASH(hash, file, len);
 207     gp->gp_file_hek = share_hek(file, len, hash);
 208     gp->gp_refcnt = 1;
 209
 210     return gp;
 211 }
 212
 213 /* Assign CvGV(cv) = gv, handling weak references.
 214  * See also S_anonymise_cv_maybe */
 215
 216 void
 217 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
 218 {
 219     GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
 220     HEK *hek;
 221     PERL_ARGS_ASSERT_CVGV_SET;
 222
 223     if (oldgv == gv)
 224         return;
 225
 226     if (oldgv) {
 227         if (CvCVGV_RC(cv)) {
 228             SvREFCNT_dec_NN(oldgv);
 229             CvCVGV_RC_off(cv);
 230         }
 231         else {
 232             sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
 233         }
 234     }
 235     else if ((hek = CvNAME_HEK(cv))) {
 236         unshare_hek(hek);
 237         CvLEXICAL_off(cv);
 238     }
 239
 240     CvNAMED_off(cv);
 241     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
 242     assert(!CvCVGV_RC(cv));
 243
 244     if (!gv)
 245         return;
 246
 247     if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
 248         Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
 249     else {
 250         CvCVGV_RC_on(cv);
 251         SvREFCNT_inc_simple_void_NN(gv);
 252     }
 253 }
 254
 255 /* Convert CvSTASH + CvNAME_HEK into a GV.  Conceptually, all subs have a
 256    GV, but for efficiency that GV may not in fact exist.  This function,
 257    called by CvGV, reifies it. */
 258
 259 GV *
 260 Perl_cvgv_from_hek(pTHX_ CV *cv)
 261 {
 262     GV *gv;
 263     SV **svp;
 264     PERL_ARGS_ASSERT_CVGV_FROM_HEK;
 265     assert(SvTYPE(cv) == SVt_PVCV);
 266     if (!CvSTASH(cv)) return NULL;
 267     ASSUME(CvNAME_HEK(cv));
 268     svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
 269     gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
 270     if (!isGV(gv))
 271         gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
 272                 HEK_LEN(CvNAME_HEK(cv)),
 273                 SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
 274     if (!CvNAMED(cv)) { /* gv_init took care of it */
 275         assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
 276         return gv;
 277     }
 278     unshare_hek(CvNAME_HEK(cv));
 279     CvNAMED_off(cv);
 280     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
 281     if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
 282     CvCVGV_RC_on(cv);
 283     return gv;
 284 }
 285
 286 /* Assign CvSTASH(cv) = st, handling weak references. */
 287
 288 void
 289 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
 290 {
 291     HV *oldst = CvSTASH(cv);
 292     PERL_ARGS_ASSERT_CVSTASH_SET;
 293     if (oldst == st)
 294         return;
 295     if (oldst)
 296         sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
 297     SvANY(cv)->xcv_stash = st;
 298     if (st)
 299         Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
 300 }
 301
 302 /*
 303 =for apidoc gv_init_pvn
 304
 305 Converts a scalar into a typeglob.  This is an incoercible typeglob;
 306 assigning a reference to it will assign to one of its slots, instead of
 307 overwriting it as happens with typeglobs created by C<SvSetSV>.  Converting
 308 any scalar that is C<SvOK()> may produce unpredictable results and is reserved
 309 for perl's internal use.
 310
 311 C<gv> is the scalar to be converted.
 312
 313 C<stash> is the parent stash/package, if any.
 314
 315 C<name> and C<len> give the name.  The name must be unqualified;
 316 that is, it must not include the package name.  If C<gv> is a
 317 stash element, it is the caller's responsibility to ensure that the name
 318 passed to this function matches the name of the element.  If it does not
 319 match, perl's internal bookkeeping will get out of sync.
 320
 321 C<flags> can be set to C<SVf_UTF8> if C<name> is a UTF-8 string, or
 322 the return value of SvUTF8(sv).  It can also take the
 323 C<GV_ADDMULTI> flag, which means to pretend that the GV has been
 324 seen before (i.e., suppress "Used once" warnings).
 325
 326 =for apidoc gv_init
 327
 328 The old form of C<gv_init_pvn()>.  It does not work with UTF-8 strings, as it
 329 has no flags parameter.  If the C<multi> parameter is set, the
 330 C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>.
 331
 332 =for apidoc gv_init_pv
 333
 334 Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name
 335 instead of separate char * and length parameters.
 336
 337 =for apidoc gv_init_sv
 338
 339 Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate
 340 char * and length parameters.  C<flags> is currently unused.
 341
 342 =cut
 343 */
 344
 345 void
 346 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
 347 {
 348    char *namepv;
 349    STRLEN namelen;
 350    PERL_ARGS_ASSERT_GV_INIT_SV;
 351    namepv = SvPV(namesv, namelen);
 352    if (SvUTF8(namesv))
 353        flags |= SVf_UTF8;
 354    gv_init_pvn(gv, stash, namepv, namelen, flags);
 355 }
 356
 357 void
 358 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
 359 {
 360    PERL_ARGS_ASSERT_GV_INIT_PV;
 361    gv_init_pvn(gv, stash, name, strlen(name), flags);
 362 }
 363
 364 void
 365 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
 366 {
 367     const U32 old_type = SvTYPE(gv);
 368     const bool doproto = old_type > SVt_NULL;
 369     char * const proto = (doproto && SvPOK(gv))
 370         ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
 371         : NULL;
 372     const STRLEN protolen = proto ? SvCUR(gv) : 0;
 373     const U32 proto_utf8  = proto ? SvUTF8(gv) : 0;
 374     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
 375     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
 376
 377     PERL_ARGS_ASSERT_GV_INIT_PVN;
 378     assert (!(proto && has_constant));
 379
 380     if (has_constant) {
 381         /* The constant has to be a scalar, array or subroutine.  */
 382         switch (SvTYPE(has_constant)) {
 383         case SVt_PVHV:
 384         case SVt_PVFM:
 385         case SVt_PVIO:
 386             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
 387                        sv_reftype(has_constant, 0));
 388             NOT_REACHED; /* NOTREACHED */
 389             break;
 390
 391         default: NOOP;
 392         }
 393         SvRV_set(gv, NULL);
 394         SvROK_off(gv);
 395     }
 396
 397
 398     if (old_type < SVt_PVGV) {
 399         if (old_type >= SVt_PV)
 400             SvCUR_set(gv, 0);
 401         sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
 402     }
 403     if (SvLEN(gv)) {
 404         if (proto) {
 405             SvPV_set(gv, NULL);
 406             SvLEN_set(gv, 0);
 407             SvPOK_off(gv);
 408         } else
 409             Safefree(SvPVX_mutable(gv));
 410     }
 411     SvIOK_off(gv);
 412     isGV_with_GP_on(gv);
 413
 414     GvGP_set(gv, Perl_newGP(aTHX_ gv));
 415     GvSTASH(gv) = stash;
 416     if (stash)
 417         Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
 418     gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
 419     if (flags & GV_ADDMULTI || doproto) /* doproto means it */
 420         GvMULTI_on(gv);                 /* _was_ mentioned */
 421     if (has_constant && SvTYPE(has_constant) == SVt_PVCV) {
 422         /* Not actually a constant.  Just a regular sub.  */
 423         CV * const cv = (CV *)has_constant;
 424         GvCV_set(gv,cv);
 425         if (CvNAMED(cv) && CvSTASH(cv) == stash && (
 426                CvNAME_HEK(cv) == GvNAME_HEK(gv)
 427             || (  HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
 428                && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
 429                && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
 430                && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
 431                )
 432            ))
 433             CvGV_set(cv,gv);
 434     }
 435     else if (doproto) {
 436         CV *cv;
 437         if (has_constant) {
 438             /* newCONSTSUB takes ownership of the reference from us.  */
 439             cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
 440             /* In case op.c:S_process_special_blocks stole it: */
 441             if (!GvCV(gv))
 442                 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
 443             assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
 444             /* If this reference was a copy of another, then the subroutine
 445                must have been "imported", by a Perl space assignment to a GV
 446                from a reference to CV.  */
 447             if (exported_constant)
 448                 GvIMPORTED_CV_on(gv);
 449             CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
 450         } else {
 451             cv = newSTUB(gv,1);
 452         }
 453         if (proto) {
 454             sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
 455                             SV_HAS_TRAILING_NUL);
 456             if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
 457         }
 458     }
 459 }
 460
 461 STATIC void
 462 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
 463 {
 464     PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
 465
 466     switch (sv_type) {
 467     case SVt_PVIO:
 468         (void)GvIOn(gv);
 469         break;
 470     case SVt_PVAV:
 471         (void)GvAVn(gv);
 472         break;
 473     case SVt_PVHV:
 474         (void)GvHVn(gv);
 475         break;
 476 #ifdef PERL_DONT_CREATE_GVSV
 477     case SVt_NULL:
 478     case SVt_PVCV:
 479     case SVt_PVFM:
 480     case SVt_PVGV:
 481         break;
 482     default:
 483         if(GvSVn(gv)) {
 484             /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
 485                If we just cast GvSVn(gv) to void, it ignores evaluating it for
 486                its side effect */
 487         }
 488 #endif
 489     }
 490 }
 491
 492 static void core_xsub(pTHX_ CV* cv);
 493
 494 static GV *
 495 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
 496                           const char * const name, const STRLEN len)
 497 {
 498     const int code = keyword(name, len, 1);
 499     static const char file[] = __FILE__;
 500     CV *cv, *oldcompcv = NULL;
 501     int opnum = 0;
 502     bool ampable = TRUE; /* &{}-able */
 503     COP *oldcurcop = NULL;
 504     yy_parser *oldparser = NULL;
 505     I32 oldsavestack_ix = 0;
 506
 507     assert(gv || stash);
 508     assert(name);
 509
 510     if (!code) return NULL; /* Not a keyword */
 511     switch (code < 0 ? -code : code) {
 512      /* no support for \&CORE::infix;
 513         no support for funcs that do not parse like funcs */
 514     case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
 515     case KEY_BEGIN   : case KEY_CHECK  : case KEY_cmp:
 516     case KEY_default : case KEY_DESTROY:
 517     case KEY_do      : case KEY_dump   : case KEY_else  : case KEY_elsif  :
 518     case KEY_END     : case KEY_eq     : case KEY_eval  :
 519     case KEY_for     : case KEY_foreach: case KEY_format: case KEY_ge     :
 520     case KEY_given   : case KEY_goto   : case KEY_grep  :
 521     case KEY_gt   : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
 522     case KEY_local: case KEY_lt: case KEY_m   : case KEY_map : case KEY_my:
 523     case KEY_ne   : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
 524     case KEY_package: case KEY_print: case KEY_printf:
 525     case KEY_q    : case KEY_qq   : case KEY_qr     : case KEY_qw    :
 526     case KEY_qx   : case KEY_redo : case KEY_require: case KEY_return:
 527     case KEY_s    : case KEY_say  : case KEY_sort   :
 528     case KEY_state: case KEY_sub  :
 529     case KEY_tr   : case KEY_UNITCHECK: case KEY_unless:
 530     case KEY_until: case KEY_use  : case KEY_when     : case KEY_while :
 531     case KEY_x    : case KEY_xor  : case KEY_y        :
 532         return NULL;
 533     case KEY_chdir:
 534     case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
 535     case KEY_eof  : case KEY_exec: case KEY_exists :
 536     case KEY_lstat:
 537     case KEY_split:
 538     case KEY_stat:
 539     case KEY_system:
 540     case KEY_truncate: case KEY_unlink:
 541         ampable = FALSE;
 542     }
 543     if (!gv) {
 544         gv = (GV *)newSV(0);
 545         gv_init(gv, stash, name, len, TRUE);
 546     }
 547     GvMULTI_on(gv);
 548     if (ampable) {
 549         ENTER;
 550         oldcurcop = PL_curcop;
 551         oldparser = PL_parser;
 552         lex_start(NULL, NULL, 0);
 553         oldcompcv = PL_compcv;
 554         PL_compcv = NULL; /* Prevent start_subparse from setting
 555                              CvOUTSIDE. */
 556         oldsavestack_ix = start_subparse(FALSE,0);
 557         cv = PL_compcv;
 558     }
 559     else {
 560         /* Avoid calling newXS, as it calls us, and things start to
 561            get hairy. */
 562         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
 563         GvCV_set(gv,cv);
 564         GvCVGEN(gv) = 0;
 565         CvISXSUB_on(cv);
 566         CvXSUB(cv) = core_xsub;
 567         PoisonPADLIST(cv);
 568     }
 569     CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
 570                          from PL_curcop. */
 571     /* XSUBs can't be perl lang/perl5db.pl debugged
 572     if (PERLDB_LINE_OR_SAVESRC)
 573         (void)gv_fetchfile(file); */
 574     CvFILE(cv) = (char *)file;
 575     /* XXX This is inefficient, as doing things this order causes
 576            a prototype check in newATTRSUB.  But we have to do
 577            it this order as we need an op number before calling
 578            new ATTRSUB. */
 579     (void)core_prototype((SV *)cv, name, code, &opnum);
 580     if (stash)
 581         (void)hv_store(stash,name,len,(SV *)gv,0);
 582     if (ampable) {
 583 #ifdef DEBUGGING
 584         CV *orig_cv = cv;
 585 #endif
 586         CvLVALUE_on(cv);
 587         /* newATTRSUB will free the CV and return NULL if we're still
 588            compiling after a syntax error */
 589         if ((cv = newATTRSUB_x(
 590                    oldsavestack_ix, (OP *)gv,
 591                    NULL,NULL,
 592                    coresub_op(
 593                      opnum
 594                        ? newSVuv((UV)opnum)
 595                        : newSVpvn(name,len),
 596                      code, opnum
 597                    ),
 598                    TRUE
 599                )) != NULL) {
 600             assert(GvCV(gv) == orig_cv);
 601             if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
 602                 && opnum != OP_UNDEF && opnum != OP_KEYS)
 603                 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
 604         }
 605         LEAVE;
 606         PL_parser = oldparser;
 607         PL_curcop = oldcurcop;
 608         PL_compcv = oldcompcv;
 609     }
 610     if (cv) {
 611         SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
 612         cv_set_call_checker(
 613           cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
 614         );
 615         SvREFCNT_dec(opnumsv);
 616     }
 617
 618     return gv;
 619 }
 620
 621 /*
 622 =for apidoc gv_fetchmeth
 623
 624 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
 625
 626 =for apidoc gv_fetchmeth_sv
 627
 628 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
 629 of an SV instead of a string/length pair.
 630
 631 =cut
 632 */
 633
 634 GV *
 635 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
 636 {
 637     char *namepv;
 638     STRLEN namelen;
 639     PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
 640     if (LIKELY(SvPOK_nog(namesv))) /* common case */
 641         return gv_fetchmeth_internal(stash, namesv, NULL, 0, level, flags);
 642     namepv = SvPV(namesv, namelen);
 643     if (SvUTF8(namesv)) flags |= SVf_UTF8;
 644     return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
 645 }
 646
 647 /*
 648 =for apidoc gv_fetchmeth_pv
 649
 650 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
 651 instead of a string/length pair.
 652
 653 =cut
 654 */
 655
 656 GV *
 657 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
 658 {
 659     PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
 660     return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
 661 }
 662
 663 /*
 664 =for apidoc gv_fetchmeth_pvn
 665
 666 Returns the glob with the given C<name> and a defined subroutine or
 667 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
 668 accessible via C<@ISA> and C<UNIVERSAL::>.
 669
 670 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 671 side-effect creates a glob with the given C<name> in the given C<stash>
 672 which in the case of success contains an alias for the subroutine, and sets
 673 up caching info for this glob.
 674
 675 The only significant values for C<flags> are C<GV_SUPER> and C<SVf_UTF8>.
 676
 677 C<GV_SUPER> indicates that we want to look up the method in the superclasses
 678 of the C<stash>.
 679
 680 The
 681 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 682 visible to Perl code.  So when calling C<call_sv>, you should not use
 683 the GV directly; instead, you should use the method's CV, which can be
 684 obtained from the GV with the C<GvCV> macro.
 685
 686 =cut
 687 */
 688
 689 /* NOTE: No support for tied ISA */
 690
 691 PERL_STATIC_INLINE GV*
 692 S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
 693 {
 694     GV** gvp;
 695     HE* he;
 696     AV* linear_av;
 697     SV** linear_svp;
 698     SV* linear_sv;
 699     HV* cstash, *cachestash;
 700     GV* candidate = NULL;
 701     CV* cand_cv = NULL;
 702     GV* topgv = NULL;
 703     const char *hvname;
 704     I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
 705     I32 items;
 706     U32 topgen_cmp;
 707     U32 is_utf8 = flags & SVf_UTF8;
 708
 709     /* UNIVERSAL methods should be callable without a stash */
 710     if (!stash) {
 711         create = 0;  /* probably appropriate */
 712         if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
 713             return 0;
 714     }
 715
 716     assert(stash);
 717
 718     hvname = HvNAME_get(stash);
 719     if (!hvname)
 720       Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 721
 722     assert(hvname);
 723     assert(name || meth);
 724
 725     DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
 726                       flags & GV_SUPER ? "SUPER " : "",
 727                       name ? name : SvPV_nolen(meth), hvname) );
 728
 729     topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
 730
 731     if (flags & GV_SUPER) {
 732         if (!HvAUX(stash)->xhv_mro_meta->super)
 733             HvAUX(stash)->xhv_mro_meta->super = newHV();
 734         cachestash = HvAUX(stash)->xhv_mro_meta->super;
 735     }
 736     else cachestash = stash;
 737
 738     /* check locally for a real method or a cache entry */
 739     he = (HE*)hv_common(
 740         cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0
 741     );
 742     if (he) gvp = (GV**)&HeVAL(he);
 743     else gvp = NULL;
 744
 745     if(gvp) {
 746         topgv = *gvp;
 747       have_gv:
 748         assert(topgv);
 749         if (SvTYPE(topgv) != SVt_PVGV)
 750         {
 751             if (!name)
 752                 name = SvPV_nomg(meth, len);
 753             gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
 754         }
 755         if ((cand_cv = GvCV(topgv))) {
 756             /* If genuine method or valid cache entry, use it */
 757             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
 758                 return topgv;
 759             }
 760             else {
 761                 /* stale cache entry, junk it and move on */
 762                 SvREFCNT_dec_NN(cand_cv);
 763                 GvCV_set(topgv, NULL);
 764                 cand_cv = NULL;
 765                 GvCVGEN(topgv) = 0;
 766             }
 767         }
 768         else if (GvCVGEN(topgv) == topgen_cmp) {
 769             /* cache indicates no such method definitively */
 770             return 0;
 771         }
 772         else if (stash == cachestash
 773               && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
 774               && strEQs(hvname, "CORE")
 775               && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
 776             goto have_gv;
 777     }
 778
 779     linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
 780     linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
 781     items = AvFILLp(linear_av); /* no +1, to skip over self */
 782     while (items--) {
 783         linear_sv = *linear_svp++;
 784         assert(linear_sv);
 785         cstash = gv_stashsv(linear_sv, 0);
 786
 787         if (!cstash) {
 788             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
 789                            "Can't locate package %" SVf " for @%" HEKf "::ISA",
 790                            SVfARG(linear_sv),
 791                            HEKfARG(HvNAME_HEK(stash)));
 792             continue;
 793         }
 794
 795         assert(cstash);
 796
 797         gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
 798         if (!gvp) {
 799             if (len > 1 && HvNAMELEN_get(cstash) == 4) {
 800                 const char *hvname = HvNAME(cstash); assert(hvname);
 801                 if (strEQs(hvname, "CORE")
 802                  && (candidate =
 803                       S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
 804                     ))
 805                     goto have_candidate;
 806             }
 807             continue;
 808         }
 809         else candidate = *gvp;
 810        have_candidate:
 811         assert(candidate);
 812         if (SvTYPE(candidate) != SVt_PVGV)
 813             gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
 814         if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 815             /*
 816              * Found real method, cache method in topgv if:
 817              *  1. topgv has no synonyms (else inheritance crosses wires)
 818              *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 819              */
 820             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 821                   CV *old_cv = GvCV(topgv);
 822                   SvREFCNT_dec(old_cv);
 823                   SvREFCNT_inc_simple_void_NN(cand_cv);
 824                   GvCV_set(topgv, cand_cv);
 825                   GvCVGEN(topgv) = topgen_cmp;
 826             }
 827             return candidate;
 828         }
 829     }
 830
 831     /* Check UNIVERSAL without caching */
 832     if(level == 0 || level == -1) {
 833         candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
 834                                           flags &~GV_SUPER);
 835         if(candidate) {
 836             cand_cv = GvCV(candidate);
 837             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 838                   CV *old_cv = GvCV(topgv);
 839                   SvREFCNT_dec(old_cv);
 840                   SvREFCNT_inc_simple_void_NN(cand_cv);
 841                   GvCV_set(topgv, cand_cv);
 842                   GvCVGEN(topgv) = topgen_cmp;
 843             }
 844             return candidate;
 845         }
 846     }
 847
 848     if (topgv && GvREFCNT(topgv) == 1) {
 849         /* cache the fact that the method is not defined */
 850         GvCVGEN(topgv) = topgen_cmp;
 851     }
 852
 853     return 0;
 854 }
 855
 856 GV *
 857 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
 858 {
 859     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
 860     return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
 861 }
 862
 863 /*
 864 =for apidoc gv_fetchmeth_autoload
 865
 866 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
 867 parameter.
 868
 869 =for apidoc gv_fetchmeth_sv_autoload
 870
 871 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
 872 of an SV instead of a string/length pair.
 873
 874 =cut
 875 */
 876
 877 GV *
 878 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
 879 {
 880    char *namepv;
 881    STRLEN namelen;
 882    PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
 883    namepv = SvPV(namesv, namelen);
 884    if (SvUTF8(namesv))
 885        flags |= SVf_UTF8;
 886    return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
 887 }
 888
 889 /*
 890 =for apidoc gv_fetchmeth_pv_autoload
 891
 892 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
 893 instead of a string/length pair.
 894
 895 =cut
 896 */
 897
 898 GV *
 899 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
 900 {
 901     PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
 902     return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
 903 }
 904
 905 /*
 906 =for apidoc gv_fetchmeth_pvn_autoload
 907
 908 Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too.
 909 Returns a glob for the subroutine.
 910
 911 For an autoloaded subroutine without a GV, will create a GV even
 912 if C<level < 0>.  For an autoloaded subroutine without a stub, C<GvCV()>
 913 of the result may be zero.
 914
 915 Currently, the only significant value for C<flags> is C<SVf_UTF8>.
 916
 917 =cut
 918 */
 919
 920 GV *
 921 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
 922 {
 923     GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
 924
 925     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
 926
 927     if (!gv) {
 928         CV *cv;
 929         GV **gvp;
 930
 931         if (!stash)
 932             return NULL;        /* UNIVERSAL::AUTOLOAD could cause trouble */
 933         if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
 934             return NULL;
 935         if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
 936             return NULL;
 937         cv = GvCV(gv);
 938         if (!(CvROOT(cv) || CvXSUB(cv)))
 939             return NULL;
 940         /* Have an autoload */
 941         if (level < 0)  /* Cannot do without a stub */
 942             gv_fetchmeth_pvn(stash, name, len, 0, flags);
 943         gvp = (GV**)hv_fetch(stash, name,
 944                         (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
 945         if (!gvp)
 946             return NULL;
 947         return *gvp;
 948     }
 949     return gv;
 950 }
 951
 952 /*
 953 =for apidoc gv_fetchmethod_autoload
 954
 955 Returns the glob which contains the subroutine to call to invoke the method
 956 on the C<stash>.  In fact in the presence of autoloading this may be the
 957 glob for "AUTOLOAD".  In this case the corresponding variable C<$AUTOLOAD> is
 958 already setup.
 959
 960 The third parameter of C<gv_fetchmethod_autoload> determines whether
 961 AUTOLOAD lookup is performed if the given method is not present: non-zero
 962 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
 963 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
 964 with a non-zero C<autoload> parameter.
 965
 966 These functions grant C<"SUPER"> token
 967 as a prefix of the method name.  Note
 968 that if you want to keep the returned glob for a long time, you need to
 969 check for it being "AUTOLOAD", since at the later time the call may load a
 970 different subroutine due to C<$AUTOLOAD> changing its value.  Use the glob
 971 created as a side effect to do this.
 972
 973 These functions have the same side-effects as C<gv_fetchmeth> with
 974 C<level==0>.  The warning against passing the GV returned by
 975 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
 976
 977 =cut
 978 */
 979
 980 GV *
 981 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 982 {
 983     PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
 984
 985     return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
 986 }
 987
 988 GV *
 989 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
 990 {
 991     char *namepv;
 992     STRLEN namelen;
 993     PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
 994     namepv = SvPV(namesv, namelen);
 995     if (SvUTF8(namesv))
 996        flags |= SVf_UTF8;
 997     return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
 998 }
 999
1000 GV *
1001 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
1002 {
1003     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
1004     return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
1005 }
1006
1007 GV *
1008 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
1009 {
1010     const char * const origname = name;
1011     const char * const name_end = name + len;
1012     const char *last_separator = NULL;
1013     GV* gv;
1014     HV* ostash = stash;
1015     SV *const error_report = MUTABLE_SV(stash);
1016     const U32 autoload = flags & GV_AUTOLOAD;
1017     const U32 do_croak = flags & GV_CROAK;
1018     const U32 is_utf8  = flags & SVf_UTF8;
1019
1020     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
1021
1022     if (SvTYPE(stash) < SVt_PVHV)
1023         stash = NULL;
1024     else {
1025         /* The only way stash can become NULL later on is if last_separator is set,
1026            which in turn means that there is no need for a SVt_PVHV case
1027            the error reporting code.  */
1028     }
1029
1030     {
1031         /* check if the method name is fully qualified or
1032          * not, and separate the package name from the actual
1033          * method name.
1034          *
1035          * leaves last_separator pointing to the beginning of the
1036          * last package separator (either ' or ::) or 0
1037          * if none was found.
1038          *
1039          * leaves name pointing at the beginning of the
1040          * method name.
1041          */
1042         const char *name_cursor = name;
1043         const char * const name_em1 = name_end - 1; /* name_end minus 1 */
1044         for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
1045             if (*name_cursor == '\'') {
1046                 last_separator = name_cursor;
1047                 name = name_cursor + 1;
1048             }
1049             else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
1050                 last_separator = name_cursor++;
1051                 name = name_cursor + 1;
1052             }
1053         }
1054     }
1055
1056     /* did we find a separator? */
1057     if (last_separator) {
1058         STRLEN sep_len= last_separator - origname;
1059         if ( memEQs(origname, sep_len, "SUPER")) {
1060             /* ->SUPER::method should really be looked up in original stash */
1061             stash = CopSTASH(PL_curcop);
1062             flags |= GV_SUPER;
1063             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1064                          origname, HvENAME_get(stash), name) );
1065         }
1066         else if ( sep_len >= 7 &&
1067                  strEQs(last_separator - 7, "::SUPER")) {
1068             /* don't autovifify if ->NoSuchStash::SUPER::method */
1069             stash = gv_stashpvn(origname, sep_len - 7, is_utf8);
1070             if (stash) flags |= GV_SUPER;
1071         }
1072         else {
1073             /* don't autovifify if ->NoSuchStash::method */
1074             stash = gv_stashpvn(origname, sep_len, is_utf8);
1075         }
1076         ostash = stash;
1077     }
1078
1079     gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1080     if (!gv) {
1081         /* This is the special case that exempts Foo->import and
1082            Foo->unimport from being an error even if there's no
1083           import/unimport subroutine */
1084         if (strEQ(name,"import") || strEQ(name,"unimport"))
1085             gv = MUTABLE_GV(&PL_sv_yes);
1086         else if (autoload)
1087             gv = gv_autoload_pvn(
1088                 ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
1089             );
1090         if (!gv && do_croak) {
1091             /* Right now this is exclusively for the benefit of S_method_common
1092                in pp_hot.c  */
1093             if (stash) {
1094                 /* If we can't find an IO::File method, it might be a call on
1095                  * a filehandle. If IO:File has not been loaded, try to
1096                  * require it first instead of croaking */
1097                 const char *stash_name = HvNAME_get(stash);
1098                 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1099                     && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1100                                        STR_WITH_LEN("IO/File.pm"), 0,
1101                                        HV_FETCH_ISEXISTS, NULL, 0)
1102                 ) {
1103                     require_pv("IO/File.pm");
1104                     gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1105                     if (gv)
1106                         return gv;
1107                 }
1108                 Perl_croak(aTHX_
1109                            "Can't locate object method \"%" UTF8f
1110                            "\" via package \"%" HEKf "\"",
1111                                     UTF8fARG(is_utf8, name_end - name, name),
1112                                     HEKfARG(HvNAME_HEK(stash)));
1113             }
1114             else {
1115                 SV* packnamesv;
1116
1117                 if (last_separator) {
1118                     packnamesv = newSVpvn_flags(origname, last_separator - origname,
1119                                                     SVs_TEMP | is_utf8);
1120                 } else {
1121                     packnamesv = error_report;
1122                 }
1123
1124                 Perl_croak(aTHX_
1125                            "Can't locate object method \"%" UTF8f
1126                            "\" via package \"%" SVf "\""
1127                            " (perhaps you forgot to load \"%" SVf "\"?)",
1128                            UTF8fARG(is_utf8, name_end - name, name),
1129                            SVfARG(packnamesv), SVfARG(packnamesv));
1130             }
1131         }
1132     }
1133     else if (autoload) {
1134         CV* const cv = GvCV(gv);
1135         if (!CvROOT(cv) && !CvXSUB(cv)) {
1136             GV* stubgv;
1137             GV* autogv;
1138
1139             if (CvANON(cv) || CvLEXICAL(cv))
1140                 stubgv = gv;
1141             else {
1142                 stubgv = CvGV(cv);
1143                 if (GvCV(stubgv) != cv)         /* orphaned import */
1144                     stubgv = gv;
1145             }
1146             autogv = gv_autoload_pvn(GvSTASH(stubgv),
1147                                   GvNAME(stubgv), GvNAMELEN(stubgv),
1148                                   GV_AUTOLOAD_ISMETHOD
1149                                    | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1150             if (autogv)
1151                 gv = autogv;
1152         }
1153     }
1154
1155     return gv;
1156 }
1157
1158 GV*
1159 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1160 {
1161    char *namepv;
1162    STRLEN namelen;
1163    PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1164    namepv = SvPV(namesv, namelen);
1165    if (SvUTF8(namesv))
1166        flags |= SVf_UTF8;
1167    return gv_autoload_pvn(stash, namepv, namelen, flags);
1168 }
1169
1170 GV*
1171 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1172 {
1173    PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1174    return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1175 }
1176
1177 GV*
1178 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1179 {
1180     GV* gv;
1181     CV* cv;
1182     HV* varstash;
1183     GV* vargv;
1184     SV* varsv;
1185     SV *packname = NULL;
1186     U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1187
1188     PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1189
1190     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1191         return NULL;
1192     if (stash) {
1193         if (SvTYPE(stash) < SVt_PVHV) {
1194             STRLEN packname_len = 0;
1195             const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1196             packname = newSVpvn_flags(packname_ptr, packname_len,
1197                                       SVs_TEMP | SvUTF8(stash));
1198             stash = NULL;
1199         }
1200         else
1201             packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1202         if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1203     }
1204     if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1205                                 is_utf8 | (flags & GV_SUPER))))
1206         return NULL;
1207     cv = GvCV(gv);
1208
1209     if (!(CvROOT(cv) || CvXSUB(cv)))
1210         return NULL;
1211
1212     /*
1213      * Inheriting AUTOLOAD for non-methods no longer works
1214      */
1215     if (
1216         !(flags & GV_AUTOLOAD_ISMETHOD)
1217      && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1218     )
1219         Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf
1220                          "::%" UTF8f "() is no longer allowed",
1221                          SVfARG(packname),
1222                          UTF8fARG(is_utf8, len, name));
1223
1224     if (CvISXSUB(cv)) {
1225         /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1226          * and split that value on the last '::', pass along the same data
1227          * via the SvPVX field in the CV, and the stash in CvSTASH.
1228          *
1229          * Due to an unfortunate accident of history, the SvPVX field
1230          * serves two purposes.  It is also used for the subroutine's pro-
1231          * type.  Since SvPVX has been documented as returning the sub name
1232          * for a long time, but not as returning the prototype, we have
1233          * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1234          * elsewhere.
1235          *
1236          * We put the prototype in the same allocated buffer, but after
1237          * the sub name.  The SvPOK flag indicates the presence of a proto-
1238          * type.  The CvAUTOLOAD flag indicates the presence of a sub name.
1239          * If both flags are on, then SvLEN is used to indicate the end of
1240          * the prototype (artificially lower than what is actually allo-
1241          * cated), at the risk of having to reallocate a few bytes unneces-
1242          * sarily--but that should happen very rarely, if ever.
1243          *
1244          * We use SvUTF8 for both prototypes and sub names, so if one is
1245          * UTF8, the other must be upgraded.
1246          */
1247         CvSTASH_set(cv, stash);
1248         if (SvPOK(cv)) { /* Ouch! */
1249             SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1250             STRLEN ulen;
1251             const char *proto = CvPROTO(cv);
1252             assert(proto);
1253             if (SvUTF8(cv))
1254                 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1255             ulen = SvCUR(tmpsv);
1256             SvCUR(tmpsv)++; /* include null in string */
1257             sv_catpvn_flags(
1258                 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1259             );
1260             SvTEMP_on(tmpsv); /* Allow theft */
1261             sv_setsv_nomg((SV *)cv, tmpsv);
1262             SvTEMP_off(tmpsv);
1263             SvREFCNT_dec_NN(tmpsv);
1264             SvLEN(cv) = SvCUR(cv) + 1;
1265             SvCUR(cv) = ulen;
1266         }
1267         else {
1268           sv_setpvn((SV *)cv, name, len);
1269           SvPOK_off(cv);
1270           if (is_utf8)
1271             SvUTF8_on(cv);
1272           else SvUTF8_off(cv);
1273         }
1274         CvAUTOLOAD_on(cv);
1275     }
1276
1277     /*
1278      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1279      * The subroutine's original name may not be "AUTOLOAD", so we don't
1280      * use that, but for lack of anything better we will use the sub's
1281      * original package to look up $AUTOLOAD.
1282      */
1283     varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1284     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1285     ENTER;
1286
1287     if (!isGV(vargv)) {
1288         gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1289 #ifdef PERL_DONT_CREATE_GVSV
1290         GvSV(vargv) = newSV(0);
1291 #endif
1292     }
1293     LEAVE;
1294     varsv = GvSVn(vargv);
1295     SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1296     /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1297     sv_setsv(varsv, packname);
1298     sv_catpvs(varsv, "::");
1299     /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1300        tainting if $FOO::AUTOLOAD was previously tainted, but is not now.  */
1301     sv_catpvn_flags(
1302         varsv, name, len,
1303         SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1304     );
1305     if (is_utf8)
1306         SvUTF8_on(varsv);
1307     return gv;
1308 }
1309
1310
1311 /* require_tie_mod() internal routine for requiring a module
1312  * that implements the logic of automatic ties like %! and %-
1313  * It loads the module and then calls the _tie_it subroutine
1314  * with the passed gv as an argument.
1315  *
1316  * The "gv" parameter should be the glob.
1317  * "varname" holds the 1-char name of the var, used for error messages.
1318  * "namesv" holds the module name. Its refcount will be decremented.
1319  * "flags": if flag & 1 then save the scalar before loading.
1320  * For the protection of $! to work (it is set by this routine)
1321  * the sv slot must already be magicalized.
1322  */
1323 STATIC void
1324 S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
1325                         STRLEN len, const U32 flags)
1326 {
1327     const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv);
1328
1329     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1330
1331     /* If it is not tied */
1332     if (!target || !SvRMAGICAL(target)
1333      || !mg_find(target,
1334                  varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied))
1335     {
1336       HV *stash;
1337       GV **gvp;
1338       dSP;
1339
1340       PUSHSTACKi(PERLSI_MAGIC);
1341       ENTER;
1342
1343 #define HV_FETCH_TIE_FUNC (GV **)hv_fetchs(stash, "_tie_it", 0)
1344
1345       /* Load the module if it is not loaded.  */
1346       if (!(stash = gv_stashpvn(name, len, 0))
1347        || !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
1348       {
1349         SV * const module = newSVpvn(name, len);
1350         const char type = varname == '[' ? '$' : '%';
1351         if ( flags & 1 )
1352             save_scalar(gv);
1353         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1354         assert(sp == PL_stack_sp);
1355         stash = gv_stashpvn(name, len, 0);
1356         if (!stash)
1357             Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
1358                     type, varname, name);
1359         else if (!(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
1360             Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
1361                     type, varname, name);
1362       }
1363       /* Now call the tie function.  It should be in *gvp.  */
1364       assert(gvp); assert(*gvp); assert(GvCV(*gvp));
1365       PUSHMARK(SP);
1366       XPUSHs((SV *)gv);
1367       PUTBACK;
1368       call_sv((SV *)*gvp, G_VOID|G_DISCARD);
1369       LEAVE;
1370       POPSTACK;
1371     }
1372 }
1373
1374 /* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes,
1375  * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in
1376  * a true string WITHOUT a len.
1377  */
1378 #define require_tie_mod_s(gv, varname, name, flags) \
1379     S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags)
1380
1381 /*
1382 =for apidoc gv_stashpv
1383
1384 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
1385 determine the length of C<name>, then calls C<gv_stashpvn()>.
1386
1387 =cut
1388 */
1389
1390 HV*
1391 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1392 {
1393     PERL_ARGS_ASSERT_GV_STASHPV;
1394     return gv_stashpvn(name, strlen(name), create);
1395 }
1396
1397 /*
1398 =for apidoc gv_stashpvn
1399
1400 Returns a pointer to the stash for a specified package.  The C<namelen>
1401 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
1402 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1403 created if it does not already exist.  If the package does not exist and
1404 C<flags> is 0 (or any other setting that does not create packages) then C<NULL>
1405 is returned.
1406
1407 Flags may be one of:
1408
1409     GV_ADD
1410     SVf_UTF8
1411     GV_NOADD_NOINIT
1412     GV_NOINIT
1413     GV_NOEXPAND
1414     GV_ADDMG
1415
1416 The most important of which are probably C<GV_ADD> and C<SVf_UTF8>.
1417
1418 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1419 recommended for performance reasons.
1420
1421 =cut
1422 */
1423
1424 /*
1425 gv_stashpvn_internal
1426
1427 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1428 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1429
1430 */
1431
1432 PERL_STATIC_INLINE HV*
1433 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1434 {
1435     char smallbuf[128];
1436     char *tmpbuf;
1437     HV *stash;
1438     GV *tmpgv;
1439     U32 tmplen = namelen + 2;
1440
1441     PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1442
1443     if (tmplen <= sizeof smallbuf)
1444         tmpbuf = smallbuf;
1445     else
1446         Newx(tmpbuf, tmplen, char);
1447     Copy(name, tmpbuf, namelen, char);
1448     tmpbuf[namelen]   = ':';
1449     tmpbuf[namelen+1] = ':';
1450     tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1451     if (tmpbuf != smallbuf)
1452         Safefree(tmpbuf);
1453     if (!tmpgv || !isGV_with_GP(tmpgv))
1454         return NULL;
1455     stash = GvHV(tmpgv);
1456     if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1457     assert(stash);
1458     if (!HvNAME_get(stash)) {
1459         hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1460
1461         /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1462         /* If the containing stash has multiple effective
1463            names, see that this one gets them, too. */
1464         if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1465             mro_package_moved(stash, NULL, tmpgv, 1);
1466     }
1467     return stash;
1468 }
1469
1470 /*
1471 gv_stashsvpvn_cached
1472
1473 Returns a pointer to the stash for a specified package, possibly
1474 cached.  Implements both C<gv_stashpvn> and C<gv_stashsv>.
1475
1476 Requires one of either namesv or namepv to be non-null.
1477
1478 See C<L</gv_stashpvn>> for details on "flags".
1479
1480 Note the sv interface is strongly preferred for performance reasons.
1481
1482 */
1483
1484 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1485     assert(namesv || name)
1486
1487 PERL_STATIC_INLINE HV*
1488 S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1489 {
1490     HV* stash;
1491     HE* he;
1492
1493     PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1494
1495     he = (HE *)hv_common(
1496         PL_stashcache, namesv, name, namelen,
1497         (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1498     );
1499
1500     if (he) {
1501         SV *sv = HeVAL(he);
1502         HV *hv;
1503         assert(SvIOK(sv));
1504         hv = INT2PTR(HV*, SvIVX(sv));
1505         assert(SvTYPE(hv) == SVt_PVHV);
1506         return hv;
1507     }
1508     else if (flags & GV_CACHE_ONLY) return NULL;
1509
1510     if (namesv) {
1511         if (SvOK(namesv)) { /* prevent double uninit warning */
1512             STRLEN len;
1513             name = SvPV_const(namesv, len);
1514             namelen = len;
1515             flags |= SvUTF8(namesv);
1516         } else {
1517             name = ""; namelen = 0;
1518         }
1519     }
1520     stash = gv_stashpvn_internal(name, namelen, flags);
1521
1522     if (stash && namelen) {
1523         SV* const ref = newSViv(PTR2IV(stash));
1524         (void)hv_store(PL_stashcache, name,
1525             (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1526     }
1527
1528     return stash;
1529 }
1530
1531 HV*
1532 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1533 {
1534     PERL_ARGS_ASSERT_GV_STASHPVN;
1535     return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1536 }
1537
1538 /*
1539 =for apidoc gv_stashsv
1540
1541 Returns a pointer to the stash for a specified package.  See
1542 C<L</gv_stashpvn>>.
1543
1544 Note this interface is strongly preferred over C<gv_stashpvn> for performance
1545 reasons.
1546
1547 =cut
1548 */
1549
1550 HV*
1551 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1552 {
1553     PERL_ARGS_ASSERT_GV_STASHSV;
1554     return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1555 }
1556
1557
1558 GV *
1559 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1560     PERL_ARGS_ASSERT_GV_FETCHPV;
1561     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1562 }
1563
1564 GV *
1565 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1566     STRLEN len;
1567     const char * const nambeg =
1568        SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1569     PERL_ARGS_ASSERT_GV_FETCHSV;
1570     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1571 }
1572
1573 PERL_STATIC_INLINE void
1574 S_gv_magicalize_isa(pTHX_ GV *gv)
1575 {
1576     AV* av;
1577
1578     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1579
1580     av = GvAVn(gv);
1581     GvMULTI_on(gv);
1582     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1583              NULL, 0);
1584 }
1585
1586 /* This function grabs name and tries to split a stash and glob
1587  * from its contents. TODO better description, comments
1588  *
1589  * If the function returns TRUE and 'name == name_end', then
1590  * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1591  */
1592 PERL_STATIC_INLINE bool
1593 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1594                STRLEN *len, const char *nambeg, STRLEN full_len,
1595                const U32 is_utf8, const I32 add)
1596 {
1597     const char *name_cursor;
1598     const char *const name_end = nambeg + full_len;
1599     const char *const name_em1 = name_end - 1;
1600
1601     PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1602
1603     if (   full_len > 2
1604         && **name == '*'
1605         && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8))
1606     {
1607         /* accidental stringify on a GV? */
1608         (*name)++;
1609     }
1610
1611     for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1612         if (name_cursor < name_em1 &&
1613             ((*name_cursor == ':' && name_cursor[1] == ':')
1614            || *name_cursor == '\''))
1615         {
1616             if (!*stash)
1617                 *stash = PL_defstash;
1618             if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1619                 return FALSE;
1620
1621             *len = name_cursor - *name;
1622             if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1623                 const char *key;
1624                 GV**gvp;
1625                 if (*name_cursor == ':') {
1626                     key = *name;
1627                     *len += 2;
1628                 }
1629                 else {
1630                     char *tmpbuf;
1631                     Newx(tmpbuf, *len+2, char);
1632                     Copy(*name, tmpbuf, *len, char);
1633                     tmpbuf[(*len)++] = ':';
1634                     tmpbuf[(*len)++] = ':';
1635                     key = tmpbuf;
1636                 }
1637                 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1638                 *gv = gvp ? *gvp : NULL;
1639                 if (*gv && *gv != (const GV *)&PL_sv_undef) {
1640                     if (SvTYPE(*gv) != SVt_PVGV)
1641                         gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1642                     else
1643                         GvMULTI_on(*gv);
1644                 }
1645                 if (key != *name)
1646                     Safefree(key);
1647                 if (!*gv || *gv == (const GV *)&PL_sv_undef)
1648                     return FALSE;
1649
1650                 if (!(*stash = GvHV(*gv))) {
1651                     *stash = GvHV(*gv) = newHV();
1652                     if (!HvNAME_get(*stash)) {
1653                         if (GvSTASH(*gv) == PL_defstash && *len == 6
1654                             && strEQs(*name, "CORE"))
1655                             hv_name_sets(*stash, "CORE", 0);
1656                         else
1657                             hv_name_set(
1658                                 *stash, nambeg, name_cursor-nambeg, is_utf8
1659                             );
1660                     /* If the containing stash has multiple effective
1661                     names, see that this one gets them, too. */
1662                     if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1663                         mro_package_moved(*stash, NULL, *gv, 1);
1664                     }
1665                 }
1666                 else if (!HvNAME_get(*stash))
1667                     hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1668             }
1669
1670             if (*name_cursor == ':')
1671                 name_cursor++;
1672             *name = name_cursor+1;
1673             if (*name == name_end) {
1674                 if (!*gv) {
1675                     *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1676                     if (SvTYPE(*gv) != SVt_PVGV) {
1677                         gv_init_pvn(*gv, PL_defstash, "main::", 6,
1678                                     GV_ADDMULTI);
1679                         GvHV(*gv) =
1680                             MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
1681                     }
1682                 }
1683                 return TRUE;
1684             }
1685         }
1686     }
1687     *len = name_cursor - *name;
1688     return TRUE;
1689 }
1690
1691 /* Checks if an unqualified name is in the main stash */
1692 PERL_STATIC_INLINE bool
1693 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1694 {
1695     PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1696
1697     /* If it's an alphanumeric variable */
1698     if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) {
1699         /* Some "normal" variables are always in main::,
1700          * like INC or STDOUT.
1701          */
1702         switch (len) {
1703             case 1:
1704             if (*name == '_')
1705                 return TRUE;
1706             break;
1707             case 3:
1708             if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1709                 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1710                 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1711                 return TRUE;
1712             break;
1713             case 4:
1714             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1715                 && name[3] == 'V')
1716                 return TRUE;
1717             break;
1718             case 5:
1719             if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1720                 && name[3] == 'I' && name[4] == 'N')
1721                 return TRUE;
1722             break;
1723             case 6:
1724             if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1725                 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1726                     ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1727                 return TRUE;
1728             break;
1729             case 7:
1730             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1731                 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1732                 && name[6] == 'T')
1733                 return TRUE;
1734             break;
1735         }
1736     }
1737     /* *{""}, or a special variable like $@ */
1738     else
1739         return TRUE;
1740
1741     return FALSE;
1742 }
1743
1744
1745 /* This function is called if parse_gv_stash_name() failed to
1746  * find a stash, or if GV_NOTQUAL or an empty name was passed
1747  * to gv_fetchpvn_flags.
1748  *
1749  * It returns FALSE if the default stash can't be found nor created,
1750  * which might happen during global destruction.
1751  */
1752 PERL_STATIC_INLINE bool
1753 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1754                const U32 is_utf8, const I32 add,
1755                const svtype sv_type)
1756 {
1757     PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1758
1759     /* No stash in name, so see how we can default */
1760
1761     if ( gv_is_in_main(name, len, is_utf8) ) {
1762         *stash = PL_defstash;
1763     }
1764     else {
1765         if (IN_PERL_COMPILETIME) {
1766             *stash = PL_curstash;
1767             if (add && (PL_hints & HINT_STRICT_VARS) &&
1768                 sv_type != SVt_PVCV &&
1769                 sv_type != SVt_PVGV &&
1770                 sv_type != SVt_PVFM &&
1771                 sv_type != SVt_PVIO &&
1772                 !(len == 1 && sv_type == SVt_PV &&
1773                 (*name == 'a' || *name == 'b')) )
1774             {
1775                 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1776                 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1777                     SvTYPE(*gvp) != SVt_PVGV)
1778                 {
1779                     *stash = NULL;
1780                 }
1781                 else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1782                          (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1783                          (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1784                 {
1785                     /* diag_listed_as: Variable "%s" is not imported%s */
1786                     Perl_ck_warner_d(
1787                         aTHX_ packWARN(WARN_MISC),
1788                         "Variable \"%c%" UTF8f "\" is not imported",
1789                         sv_type == SVt_PVAV ? '@' :
1790                         sv_type == SVt_PVHV ? '%' : '$',
1791                         UTF8fARG(is_utf8, len, name));
1792                     if (GvCVu(*gvp))
1793                         Perl_ck_warner_d(
1794                             aTHX_ packWARN(WARN_MISC),
1795                             "\t(Did you mean &%" UTF8f " instead?)\n",
1796                             UTF8fARG(is_utf8, len, name)
1797                         );
1798                     *stash = NULL;
1799                 }
1800             }
1801         }
1802         else {
1803             /* Use the current op's stash */
1804             *stash = CopSTASH(PL_curcop);
1805         }
1806     }
1807
1808     if (!*stash) {
1809         if (add && !PL_in_clean_all) {
1810             GV *gv;
1811             qerror(Perl_mess(aTHX_
1812                  "Global symbol \"%s%" UTF8f
1813                  "\" requires explicit package name (did you forget to "
1814                  "declare \"my %s%" UTF8f "\"?)",
1815                  (sv_type == SVt_PV ? "$"
1816                   : sv_type == SVt_PVAV ? "@"
1817                   : sv_type == SVt_PVHV ? "%"
1818                   : ""), UTF8fARG(is_utf8, len, name),
1819                  (sv_type == SVt_PV ? "$"
1820                   : sv_type == SVt_PVAV ? "@"
1821                   : sv_type == SVt_PVHV ? "%"
1822                   : ""), UTF8fARG(is_utf8, len, name)));
1823             /* To maintain the output of errors after the strict exception
1824              * above, and to keep compat with older releases, rather than
1825              * placing the variables in the pad, we place
1826              * them in the <none>:: stash.
1827              */
1828             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1829             if (!gv) {
1830                 /* symbol table under destruction */
1831                 return FALSE;
1832             }
1833             *stash = GvHV(gv);
1834         }
1835         else
1836             return FALSE;
1837     }
1838
1839     if (!SvREFCNT(*stash))   /* symbol table under destruction */
1840         return FALSE;
1841
1842     return TRUE;
1843 }
1844
1845 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT.  So
1846    redefine SvREADONLY_on for that purpose.  We don’t use it later on in
1847    this file.  */
1848 #undef SvREADONLY_on
1849 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
1850
1851 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1852  * a new GV.
1853  * Note that it does not insert the GV into the stash prior to
1854  * magicalization, which some variables require need in order
1855  * to work (like $[, %+, %-, %!), so callers must take care of
1856  * that.
1857  *
1858  * It returns true if the gv did turn out to be magical one; i.e.,
1859  * if gv_magicalize actually did something.
1860  */
1861 PERL_STATIC_INLINE bool
1862 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1863                       const svtype sv_type)
1864 {
1865     SSize_t paren;
1866
1867     PERL_ARGS_ASSERT_GV_MAGICALIZE;
1868
1869     if (stash != PL_defstash) { /* not the main stash */
1870         /* We only have to check for a few names here: a, b, EXPORT, ISA
1871            and VERSION. All the others apply only to the main stash or to
1872            CORE (which is checked right after this). */
1873         if (len) {
1874             switch (*name) {
1875             case 'E':
1876                 if (
1877                     len >= 6 && name[1] == 'X' &&
1878                     (memEQs(name, len, "EXPORT")
1879                     ||memEQs(name, len, "EXPORT_OK")
1880                     ||memEQs(name, len, "EXPORT_FAIL")
1881                     ||memEQs(name, len, "EXPORT_TAGS"))
1882                 )
1883                     GvMULTI_on(gv);
1884                 break;
1885             case 'I':
1886                 if (memEQs(name, len, "ISA"))
1887                     gv_magicalize_isa(gv);
1888                 break;
1889             case 'V':
1890                 if (memEQs(name, len, "VERSION"))
1891                     GvMULTI_on(gv);
1892                 break;
1893             case 'a':
1894                 if (stash == PL_debstash && memEQs(name, len, "args")) {
1895                     GvMULTI_on(gv_AVadd(gv));
1896                     break;
1897                 }
1898                 /* FALLTHROUGH */
1899             case 'b':
1900                 if (len == 1 && sv_type == SVt_PV)
1901                     GvMULTI_on(gv);
1902                 /* FALLTHROUGH */
1903             default:
1904                 goto try_core;
1905             }
1906             goto ret;
1907         }
1908       try_core:
1909         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1910           /* Avoid null warning: */
1911           const char * const stashname = HvNAME(stash); assert(stashname);
1912           if (strEQs(stashname, "CORE"))
1913             S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1914         }
1915     }
1916     else if (len > 1) {
1917 #ifndef EBCDIC
1918         if (*name > 'V' ) {
1919             NOOP;
1920             /* Nothing else to do.
1921                The compiler will probably turn the switch statement into a
1922                branch table. Make sure we avoid even that small overhead for
1923                the common case of lower case variable names.  (On EBCDIC
1924                platforms, we can't just do:
1925                  if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1926                because cases like '\027' in the switch statement below are
1927                C1 (non-ASCII) controls on those platforms, so the remapping
1928                would make them larger than 'V')
1929              */
1930         } else
1931 #endif
1932         {
1933             switch (*name) {
1934             case 'A':
1935                 if (memEQs(name, len, "ARGV")) {
1936                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1937                 }
1938                 else if (memEQs(name, len, "ARGVOUT")) {
1939                     GvMULTI_on(gv);
1940                 }
1941                 break;
1942             case 'E':
1943                 if (
1944                     len >= 6 && name[1] == 'X' &&
1945                     (memEQs(name, len, "EXPORT")
1946                     ||memEQs(name, len, "EXPORT_OK")
1947                     ||memEQs(name, len, "EXPORT_FAIL")
1948                     ||memEQs(name, len, "EXPORT_TAGS"))
1949                 )
1950                     GvMULTI_on(gv);
1951                 break;
1952             case 'I':
1953                 if (memEQs(name, len, "ISA")) {
1954                     gv_magicalize_isa(gv);
1955                 }
1956                 break;
1957             case 'S':
1958                 if (memEQs(name, len, "SIG")) {
1959                     HV *hv;
1960                     I32 i;
1961                     if (!PL_psig_name) {
1962                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1963                         Newxz(PL_psig_pend, SIG_SIZE, int);
1964                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1965                     } else {
1966                         /* I think that the only way to get here is to re-use an
1967                            embedded perl interpreter, where the previous
1968                            use didn't clean up fully because
1969                            PL_perl_destruct_level was 0. I'm not sure that we
1970                            "support" that, in that I suspect in that scenario
1971                            there are sufficient other garbage values left in the
1972                            interpreter structure that something else will crash
1973                            before we get here. I suspect that this is one of
1974                            those "doctor, it hurts when I do this" bugs.  */
1975                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1976                         Zero(PL_psig_pend, SIG_SIZE, int);
1977                     }
1978                     GvMULTI_on(gv);
1979                     hv = GvHVn(gv);
1980                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1981                     for (i = 1; i < SIG_SIZE; i++) {
1982                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1983                         if (init)
1984                             sv_setsv(*init, &PL_sv_undef);
1985                     }
1986                 }
1987                 break;
1988             case 'V':
1989                 if (memEQs(name, len, "VERSION"))
1990                     GvMULTI_on(gv);
1991                 break;
1992             case '\003':        /* $^CHILD_ERROR_NATIVE */
1993                 if (memEQs(name, len, "\003HILD_ERROR_NATIVE"))
1994                     goto magicalize;
1995                                 /* @{^CAPTURE} %{^CAPTURE} */
1996                 if (memEQs(name, len, "\003APTURE")) {
1997                     AV* const av = GvAVn(gv);
1998                     UV uv= *name;
1999
2000                     sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0);
2001                     SvREADONLY_on(av);
2002
2003                     if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2004                         require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
2005
2006                 } else          /* %{^CAPTURE_ALL} */
2007                 if (memEQs(name, len, "\003APTURE_ALL")) {
2008                     if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2009                         require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
2010                 }
2011                 break;
2012             case '\005':        /* $^ENCODING */
2013                 if (memEQs(name, len, "\005NCODING"))
2014                     goto magicalize;
2015                 break;
2016             case '\007':        /* $^GLOBAL_PHASE */
2017                 if (memEQs(name, len, "\007LOBAL_PHASE"))
2018                     goto ro_magicalize;
2019                 break;
2020             case '\014':        /* $^LAST_FH */
2021                 if (memEQs(name, len, "\014AST_FH"))
2022                     goto ro_magicalize;
2023                 break;
2024             case '\015':        /* $^MATCH */
2025                 if (memEQs(name, len, "\015ATCH")) {
2026                     paren = RX_BUFF_IDX_CARET_FULLMATCH;
2027                     goto storeparen;
2028                 }
2029                 break;
2030             case '\017':        /* $^OPEN */
2031                 if (memEQs(name, len, "\017PEN"))
2032                     goto magicalize;
2033                 break;
2034             case '\020':        /* $^PREMATCH  $^POSTMATCH */
2035                 if (memEQs(name, len, "\020REMATCH")) {
2036                     paren = RX_BUFF_IDX_CARET_PREMATCH;
2037                     goto storeparen;
2038                 }
2039                 if (memEQs(name, len, "\020OSTMATCH")) {
2040                     paren = RX_BUFF_IDX_CARET_POSTMATCH;
2041                     goto storeparen;
2042                 }
2043                 break;
2044             case '\024':        /* ${^TAINT} */
2045                 if (memEQs(name, len, "\024AINT"))
2046                     goto ro_magicalize;
2047                 break;
2048             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
2049                 if (memEQs(name, len, "\025NICODE"))
2050                     goto ro_magicalize;
2051                 if (memEQs(name, len, "\025TF8LOCALE"))
2052                     goto ro_magicalize;
2053                 if (memEQs(name, len, "\025TF8CACHE"))
2054                     goto magicalize;
2055                 break;
2056             case '\027':        /* $^WARNING_BITS */
2057                 if (memEQs(name, len, "\027ARNING_BITS"))
2058                     goto magicalize;
2059 #ifdef WIN32
2060                 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT"))
2061                     goto magicalize;
2062 #endif
2063                 break;
2064             case '1':
2065             case '2':
2066             case '3':
2067             case '4':
2068             case '5':
2069             case '6':
2070             case '7':
2071             case '8':
2072             case '9':
2073             {
2074                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
2075                    this test  */
2076                 UV uv;
2077                 if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
2078                     goto ret;
2079                 /* XXX why are we using a SSize_t? */
2080                 paren = (SSize_t)(I32)uv;
2081                 goto storeparen;
2082             }
2083             }
2084         }
2085     } else {
2086         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
2087            be case '\0' in this switch statement (ie a default case)  */
2088         switch (*name) {
2089         case '&':               /* $& */
2090             paren = RX_BUFF_IDX_FULLMATCH;
2091             goto sawampersand;
2092         case '`':               /* $` */
2093             paren = RX_BUFF_IDX_PREMATCH;
2094             goto sawampersand;
2095         case '\'':              /* $' */
2096             paren = RX_BUFF_IDX_POSTMATCH;
2097         sawampersand:
2098 #ifdef PERL_SAWAMPERSAND
2099             if (!(
2100                 sv_type == SVt_PVAV ||
2101                 sv_type == SVt_PVHV ||
2102                 sv_type == SVt_PVCV ||
2103                 sv_type == SVt_PVFM ||
2104                 sv_type == SVt_PVIO
2105                 )) { PL_sawampersand |=
2106                         (*name == '`')
2107                             ? SAWAMPERSAND_LEFT
2108                             : (*name == '&')
2109                                 ? SAWAMPERSAND_MIDDLE
2110                                 : SAWAMPERSAND_RIGHT;
2111                 }
2112 #endif
2113             goto storeparen;
2114         case '1':               /* $1 */
2115         case '2':               /* $2 */
2116         case '3':               /* $3 */
2117         case '4':               /* $4 */
2118         case '5':               /* $5 */
2119         case '6':               /* $6 */
2120         case '7':               /* $7 */
2121         case '8':               /* $8 */
2122         case '9':               /* $9 */
2123             paren = *name - '0';
2124
2125         storeparen:
2126             /* Flag the capture variables with a NULL mg_ptr
2127                Use mg_len for the array index to lookup.  */
2128             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
2129             break;
2130
2131         case ':':               /* $: */
2132             sv_setpv(GvSVn(gv),PL_chopset);
2133             goto magicalize;
2134
2135         case '?':               /* $? */
2136 #ifdef COMPLEX_STATUS
2137             SvUPGRADE(GvSVn(gv), SVt_PVLV);
2138 #endif
2139             goto magicalize;
2140
2141         case '!':               /* $! */
2142             GvMULTI_on(gv);
2143             /* If %! has been used, automatically load Errno.pm. */
2144
2145             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2146
2147             /* magicalization must be done before require_tie_mod_s is called */
2148             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2149                 require_tie_mod_s(gv, '!', "Errno", 1);
2150
2151             break;
2152         case '-':               /* $-, %-, @- */
2153         case '+':               /* $+, %+, @+ */
2154             GvMULTI_on(gv); /* no used once warnings here */
2155             {   /* $- $+ */
2156                 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2157                 if (*name == '+')
2158                     SvREADONLY_on(GvSVn(gv));
2159             }
2160             {   /* %- %+ */
2161                 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2162                     require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0);
2163             }
2164             {   /* @- @+ */
2165                 AV* const av = GvAVn(gv);
2166                 const UV uv = (UV)*name;
2167
2168                 sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0);
2169                 SvREADONLY_on(av);
2170             }
2171             break;
2172         case '*':               /* $* */
2173         case '#':               /* $# */
2174             if (sv_type == SVt_PV)
2175                 /* diag_listed_as: $* is no longer supported. Its use will be fatal in Perl 5.30 */
2176                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
2177                                  "$%c is no longer supported. Its use "
2178                                  "will be fatal in Perl 5.30", *name);
2179             break;
2180         case '\010':    /* $^H */
2181             {
2182                 HV *const hv = GvHVn(gv);
2183                 hv_magic(hv, NULL, PERL_MAGIC_hints);
2184             }
2185             goto magicalize;
2186         case '[':               /* $[ */
2187             if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
2188              && FEATURE_ARYBASE_IS_ENABLED) {
2189                 require_tie_mod_s(gv,'[',"arybase",0);
2190             }
2191             else goto magicalize;
2192             break;
2193         case '\023':    /* $^S */
2194         ro_magicalize:
2195             SvREADONLY_on(GvSVn(gv));
2196             /* FALLTHROUGH */
2197         case '0':               /* $0 */
2198         case '^':               /* $^ */
2199         case '~':               /* $~ */
2200         case '=':               /* $= */
2201         case '%':               /* $% */
2202         case '.':               /* $. */
2203         case '(':               /* $( */
2204         case ')':               /* $) */
2205         case '<':               /* $< */
2206         case '>':               /* $> */
2207         case '\\':              /* $\ */
2208         case '/':               /* $/ */
2209         case '|':               /* $| */
2210         case '$':               /* $$ */
2211         case '\001':    /* $^A */
2212         case '\003':    /* $^C */
2213         case '\004':    /* $^D */
2214         case '\005':    /* $^E */
2215         case '\006':    /* $^F */
2216         case '\011':    /* $^I, NOT \t in EBCDIC */
2217         case '\016':    /* $^N */
2218         case '\017':    /* $^O */
2219         case '\020':    /* $^P */
2220         case '\024':    /* $^T */
2221         case '\027':    /* $^W */
2222         magicalize:
2223             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2224             break;
2225
2226         case '\014':    /* $^L */
2227             sv_setpvs(GvSVn(gv),"\f");
2228             break;
2229         case ';':               /* $; */
2230             sv_setpvs(GvSVn(gv),"\034");
2231             break;
2232         case ']':               /* $] */
2233         {
2234             SV * const sv = GvSV(gv);
2235             if (!sv_derived_from(PL_patchlevel, "version"))
2236                 upg_version(PL_patchlevel, TRUE);
2237             GvSV(gv) = vnumify(PL_patchlevel);
2238             SvREADONLY_on(GvSV(gv));
2239             SvREFCNT_dec(sv);
2240         }
2241         break;
2242         case '\026':    /* $^V */
2243         {
2244             SV * const sv = GvSV(gv);
2245             GvSV(gv) = new_version(PL_patchlevel);
2246             SvREADONLY_on(GvSV(gv));
2247             SvREFCNT_dec(sv);
2248         }
2249         break;
2250         case 'a':
2251         case 'b':
2252             if (sv_type == SVt_PV)
2253                 GvMULTI_on(gv);
2254         }
2255     }
2256
2257    ret:
2258     /* Return true if we actually did something.  */
2259     return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv)
2260         || ( GvSV(gv) && (
2261                            SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))
2262                          )
2263            );
2264 }
2265
2266 /* If we do ever start using this later on in the file, we need to make
2267    sure we don’t accidentally use the wrong definition.  */
2268 #undef SvREADONLY_on
2269
2270 /* This function is called when the stash already holds the GV of the magic
2271  * variable we're looking for, but we need to check that it has the correct
2272  * kind of magic.  For example, if someone first uses $! and then %!, the
2273  * latter would end up here, and we add the Errno tie to the HASH slot of
2274  * the *! glob.
2275  */
2276 PERL_STATIC_INLINE void
2277 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2278 {
2279     PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2280
2281     if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2282         if (*name == '!')
2283             require_tie_mod_s(gv, '!', "Errno", 1);
2284         else if (*name == '-' || *name == '+')
2285             require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
2286     } else if (sv_type == SVt_PV) {
2287         if (*name == '*' || *name == '#') {
2288             /* diag_listed_as: $# is no longer supported. Its use will be fatal in Perl 5.30 */
2289             Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
2290                                              WARN_SYNTAX),
2291                              "$%c is no longer supported. Its use "
2292                              "will be fatal in Perl 5.30", *name);
2293         }
2294     }
2295     if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2296       switch (*name) {
2297       case '[':
2298           require_tie_mod_s(gv,'[',"arybase",0);
2299           break;
2300 #ifdef PERL_SAWAMPERSAND
2301       case '`':
2302           PL_sawampersand |= SAWAMPERSAND_LEFT;
2303           (void)GvSVn(gv);
2304           break;
2305       case '&':
2306           PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2307           (void)GvSVn(gv);
2308           break;
2309       case '\'':
2310           PL_sawampersand |= SAWAMPERSAND_RIGHT;
2311           (void)GvSVn(gv);
2312           break;
2313 #endif
2314       }
2315     }
2316 }
2317
2318 GV *
2319 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2320                        const svtype sv_type)
2321 {
2322     const char *name = nambeg;
2323     GV *gv = NULL;
2324     GV**gvp;
2325     STRLEN len;
2326     HV *stash = NULL;
2327     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2328     const I32 no_expand = flags & GV_NOEXPAND;
2329     const I32 add = flags & ~GV_NOADD_MASK;
2330     const U32 is_utf8 = flags & SVf_UTF8;
2331     bool addmg = cBOOL(flags & GV_ADDMG);
2332     const char *const name_end = nambeg + full_len;
2333     U32 faking_it;
2334
2335     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2336
2337      /* If we have GV_NOTQUAL, the caller promised that
2338       * there is no stash, so we can skip the check.
2339       * Similarly if full_len is 0, since then we're
2340       * dealing with something like *{""} or ""->foo()
2341       */
2342     if ((flags & GV_NOTQUAL) || !full_len) {
2343         len = full_len;
2344     }
2345     else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2346         if (name == name_end) return gv;
2347     }
2348     else {
2349         return NULL;
2350     }
2351
2352     if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2353         return NULL;
2354     }
2355
2356     /* By this point we should have a stash and a name */
2357     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2358     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2359         if (addmg) gv = (GV *)newSV(0);
2360         else return NULL;
2361     }
2362     else gv = *gvp, addmg = 0;
2363     /* From this point on, addmg means gv has not been inserted in the
2364        symtab yet. */
2365
2366     if (SvTYPE(gv) == SVt_PVGV) {
2367         /* The GV already exists, so return it, but check if we need to do
2368          * anything else with it before that.
2369          */
2370         if (add) {
2371             /* This is the heuristic that handles if a variable triggers the
2372              * 'used only once' warning.  If there's already a GV in the stash
2373              * with this name, then we assume that the variable has been used
2374              * before and turn its MULTI flag on.
2375              * It's a heuristic because it can easily be "tricked", like with
2376              * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2377              * not warning about $main::foo being used just once
2378              */
2379             GvMULTI_on(gv);
2380             gv_init_svtype(gv, sv_type);
2381             /* You reach this path once the typeglob has already been created,
2382                either by the same or a different sigil.  If this path didn't
2383                exist, then (say) referencing $! first, and %! second would
2384                mean that %! was not handled correctly.  */
2385             if (len == 1 && stash == PL_defstash) {
2386                 maybe_multimagic_gv(gv, name, sv_type);
2387             }
2388             else if (len == 3 && sv_type == SVt_PVAV
2389                   && strEQs(name, "ISA")
2390                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2391                 gv_magicalize_isa(gv);
2392         }
2393         return gv;
2394     } else if (no_init) {
2395         assert(!addmg);
2396         return gv;
2397     }
2398     /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2399      * don't expand it to a glob. This is an optimization so that things
2400      * copying constants over, like Exporter, don't have to be rewritten
2401      * to take into account that you can store more than just globs in
2402      * stashes.
2403      */
2404     else if (no_expand && SvROK(gv)) {
2405         assert(!addmg);
2406         return gv;
2407     }
2408
2409     /* Adding a new symbol.
2410        Unless of course there was already something non-GV here, in which case
2411        we want to behave as if there was always a GV here, containing some sort
2412        of subroutine.
2413        Otherwise we run the risk of creating things like GvIO, which can cause
2414        subtle bugs. eg the one that tripped up SQL::Translator  */
2415
2416     faking_it = SvOK(gv);
2417
2418     if (add & GV_ADDWARN)
2419         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2420                 "Had to create %" UTF8f " unexpectedly",
2421                  UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2422     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2423
2424     if (   full_len != 0
2425         && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8)
2426         && !ckWARN(WARN_ONCE) )
2427     {
2428         GvMULTI_on(gv) ;
2429     }
2430
2431     /* set up magic where warranted */
2432     if ( gv_magicalize(gv, stash, name, len, sv_type) ) {
2433         /* See 23496c6 */
2434         if (addmg) {
2435                 /* gv_magicalize magicalised this gv, so we want it
2436                  * stored in the symtab.
2437                  * Effectively the caller is asking, ‘Does this gv exist?’
2438                  * And we respond, ‘Er, *now* it does!’
2439                  */
2440                 (void)hv_store(stash,name,len,(SV *)gv,0);
2441         }
2442     }
2443     else if (addmg) {
2444                 /* The temporary GV created above */
2445                 SvREFCNT_dec_NN(gv);
2446                 gv = NULL;
2447     }
2448
2449     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2450     return gv;
2451 }
2452
2453 void
2454 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2455 {
2456     const char *name;
2457     const HV * const hv = GvSTASH(gv);
2458
2459     PERL_ARGS_ASSERT_GV_FULLNAME4;
2460
2461     sv_setpv(sv, prefix ? prefix : "");
2462
2463     if (hv && (name = HvNAME(hv))) {
2464       const STRLEN len = HvNAMELEN(hv);
2465       if (keepmain || strnNE(name, "main", len)) {
2466         sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2467         sv_catpvs(sv,"::");
2468       }
2469     }
2470     else sv_catpvs(sv,"__ANON__::");
2471     sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2472 }
2473
2474 void
2475 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2476 {
2477     const GV * const egv = GvEGVx(gv);
2478
2479     PERL_ARGS_ASSERT_GV_EFULLNAME4;
2480
2481     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2482 }
2483
2484
2485 /* recursively scan a stash and any nested stashes looking for entries
2486  * that need the "only used once" warning raised
2487  */
2488
2489 void
2490 Perl_gv_check(pTHX_ HV *stash)
2491 {
2492     I32 i;
2493
2494     PERL_ARGS_ASSERT_GV_CHECK;
2495
2496     if (!SvOOK(stash))
2497         return;
2498
2499     assert(HvARRAY(stash));
2500
2501     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2502         const HE *entry;
2503         /* mark stash is being scanned, to avoid recursing */
2504         HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2505         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2506             GV *gv;
2507             HV *hv;
2508             STRLEN keylen = HeKLEN(entry);
2509             const char * const key = HeKEY(entry);
2510
2511             if (keylen >= 2 && key[keylen-2] == ':'  && key[keylen-1] == ':' &&
2512                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2513             {
2514                 if (hv != PL_defstash && hv != stash
2515                     && !(SvOOK(hv)
2516                         && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2517                 )
2518                      gv_check(hv);              /* nested package */
2519             }
2520             else if (   HeKLEN(entry) != 0
2521                      && *HeKEY(entry) != '_'
2522                      && isIDFIRST_lazy_if_safe(HeKEY(entry),
2523                                                HeKEY(entry) + HeKLEN(entry),
2524                                                HeUTF8(entry)) )
2525             {
2526                 const char *file;
2527                 gv = MUTABLE_GV(HeVAL(entry));
2528                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2529                     continue;
2530                 file = GvFILE(gv);
2531                 CopLINE_set(PL_curcop, GvLINE(gv));
2532 #ifdef USE_ITHREADS
2533                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
2534 #else
2535                 CopFILEGV(PL_curcop)
2536                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2537 #endif
2538                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2539                         "Name \"%" HEKf "::%" HEKf
2540                         "\" used only once: possible typo",
2541                             HEKfARG(HvNAME_HEK(stash)),
2542                             HEKfARG(GvNAME_HEK(gv)));
2543             }
2544         }
2545         HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2546     }
2547 }
2548
2549 GV *
2550 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2551 {
2552     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2553     assert(!(flags & ~SVf_UTF8));
2554
2555     return gv_fetchpv(Perl_form(aTHX_ "%" UTF8f "::_GEN_%ld",
2556                                 UTF8fARG(flags, strlen(pack), pack),
2557                                 (long)PL_gensym++),
2558                       GV_ADD, SVt_PVGV);
2559 }
2560
2561 /* hopefully this is only called on local symbol table entries */
2562
2563 GP*
2564 Perl_gp_ref(pTHX_ GP *gp)
2565 {
2566     if (!gp)
2567         return NULL;
2568     gp->gp_refcnt++;
2569     if (gp->gp_cv) {
2570         if (gp->gp_cvgen) {
2571             /* If the GP they asked for a reference to contains
2572                a method cache entry, clear it first, so that we
2573                don't infect them with our cached entry */
2574             SvREFCNT_dec_NN(gp->gp_cv);
2575             gp->gp_cv = NULL;
2576             gp->gp_cvgen = 0;
2577         }
2578     }
2579     return gp;
2580 }
2581
2582 void
2583 Perl_gp_free(pTHX_ GV *gv)
2584 {
2585     GP* gp;
2586     int attempts = 100;
2587
2588     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2589         return;
2590     if (gp->gp_refcnt == 0) {
2591         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2592                          "Attempt to free unreferenced glob pointers"
2593                          pTHX__FORMAT pTHX__VALUE);
2594         return;
2595     }
2596     if (gp->gp_refcnt > 1) {
2597        borrowed:
2598         if (gp->gp_egv == gv)
2599             gp->gp_egv = 0;
2600         gp->gp_refcnt--;
2601         GvGP_set(gv, NULL);
2602         return;
2603     }
2604
2605     while (1) {
2606       /* Copy and null out all the glob slots, so destructors do not see
2607          freed SVs. */
2608       HEK * const file_hek = gp->gp_file_hek;
2609       SV  * const sv       = gp->gp_sv;
2610       AV  * const av       = gp->gp_av;
2611       HV  * const hv       = gp->gp_hv;
2612       IO  * const io       = gp->gp_io;
2613       CV  * const cv       = gp->gp_cv;
2614       CV  * const form     = gp->gp_form;
2615
2616       gp->gp_file_hek = NULL;
2617       gp->gp_sv       = NULL;
2618       gp->gp_av       = NULL;
2619       gp->gp_hv       = NULL;
2620       gp->gp_io       = NULL;
2621       gp->gp_cv       = NULL;
2622       gp->gp_form     = NULL;
2623
2624       if (file_hek)
2625         unshare_hek(file_hek);
2626
2627       SvREFCNT_dec(sv);
2628       SvREFCNT_dec(av);
2629       /* FIXME - another reference loop GV -> symtab -> GV ?
2630          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2631       if (hv && SvTYPE(hv) == SVt_PVHV) {
2632         const HEK *hvname_hek = HvNAME_HEK(hv);
2633         if (PL_stashcache && hvname_hek) {
2634            DEBUG_o(Perl_deb(aTHX_
2635                           "gp_free clearing PL_stashcache for '%" HEKf "'\n",
2636                            HEKfARG(hvname_hek)));
2637            (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2638         }
2639         SvREFCNT_dec(hv);
2640       }
2641       if (io && SvREFCNT(io) == 1 && IoIFP(io)
2642              && (IoTYPE(io) == IoTYPE_WRONLY ||
2643                  IoTYPE(io) == IoTYPE_RDWR   ||
2644                  IoTYPE(io) == IoTYPE_APPEND)
2645              && ckWARN_d(WARN_IO)
2646              && IoIFP(io) != PerlIO_stdin()
2647              && IoIFP(io) != PerlIO_stdout()
2648              && IoIFP(io) != PerlIO_stderr()
2649              && !(IoFLAGS(io) & IOf_FAKE_DIRP))
2650         io_close(io, gv, FALSE, TRUE);
2651       SvREFCNT_dec(io);
2652       SvREFCNT_dec(cv);
2653       SvREFCNT_dec(form);
2654
2655       /* Possibly reallocated by a destructor */
2656       gp = GvGP(gv);
2657
2658       if (!gp->gp_file_hek
2659        && !gp->gp_sv
2660        && !gp->gp_av
2661        && !gp->gp_hv
2662        && !gp->gp_io
2663        && !gp->gp_cv
2664        && !gp->gp_form) break;
2665
2666       if (--attempts == 0) {
2667         Perl_die(aTHX_
2668           "panic: gp_free failed to free glob pointer - "
2669           "something is repeatedly re-creating entries"
2670         );
2671       }
2672     }
2673
2674     /* Possibly incremented by a destructor doing glob assignment */
2675     if (gp->gp_refcnt > 1) goto borrowed;
2676     Safefree(gp);
2677     GvGP_set(gv, NULL);
2678 }
2679
2680 int
2681 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2682 {
2683     AMT * const amtp = (AMT*)mg->mg_ptr;
2684     PERL_UNUSED_ARG(sv);
2685
2686     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2687
2688     if (amtp && AMT_AMAGIC(amtp)) {
2689         int i;
2690         for (i = 1; i < NofAMmeth; i++) {
2691             CV * const cv = amtp->table[i];
2692             if (cv) {
2693                 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2694                 amtp->table[i] = NULL;
2695             }
2696         }
2697     }
2698  return 0;
2699 }
2700
2701 /* Updates and caches the CV's */
2702 /* Returns:
2703  * 1 on success and there is some overload
2704  * 0 if there is no overload
2705  * -1 if some error occurred and it couldn't croak
2706  */
2707
2708 int
2709 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2710 {
2711   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2712   AMT amt;
2713   const struct mro_meta* stash_meta = HvMROMETA(stash);
2714   U32 newgen;
2715
2716   PERL_ARGS_ASSERT_GV_AMUPDATE;
2717
2718   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2719   if (mg) {
2720       const AMT * const amtp = (AMT*)mg->mg_ptr;
2721       if (amtp->was_ok_sub == newgen) {
2722           return AMT_AMAGIC(amtp) ? 1 : 0;
2723       }
2724       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2725   }
2726
2727   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2728
2729   Zero(&amt,1,AMT);
2730   amt.was_ok_sub = newgen;
2731   amt.fallback = AMGfallNO;
2732   amt.flags = 0;
2733
2734   {
2735     int filled = 0;
2736     int i;
2737     bool deref_seen = 0;
2738
2739
2740     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2741
2742     /* Try to find via inheritance. */
2743     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2744     SV * const sv = gv ? GvSV(gv) : NULL;
2745     CV* cv;
2746
2747     if (!gv)
2748     {
2749       if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2750         goto no_table;
2751     }
2752 #ifdef PERL_DONT_CREATE_GVSV
2753     else if (!sv) {
2754         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2755     }
2756 #endif
2757     else if (SvTRUE(sv))
2758         /* don't need to set overloading here because fallback => 1
2759          * is the default setting for classes without overloading */
2760         amt.fallback=AMGfallYES;
2761     else if (SvOK(sv)) {
2762         amt.fallback=AMGfallNEVER;
2763         filled = 1;
2764     }
2765     else {
2766         filled = 1;
2767     }
2768
2769     assert(SvOOK(stash));
2770     /* initially assume the worst */
2771     HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
2772
2773     for (i = 1; i < NofAMmeth; i++) {
2774         const char * const cooky = PL_AMG_names[i];
2775         /* Human-readable form, for debugging: */
2776         const char * const cp = AMG_id2name(i);
2777         const STRLEN l = PL_AMG_namelens[i];
2778
2779         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2780                      cp, HvNAME_get(stash)) );
2781         /* don't fill the cache while looking up!
2782            Creation of inheritance stubs in intermediate packages may
2783            conflict with the logic of runtime method substitution.
2784            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2785            then we could have created stubs for "(+0" in A and C too.
2786            But if B overloads "bool", we may want to use it for
2787            numifying instead of C's "+0". */
2788         gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2789         cv = 0;
2790         if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
2791             const HEK * const gvhek =
2792                 CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(cv));
2793             const HEK * const stashek =
2794                 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
2795             if (HEK_LEN(gvhek) == 3 && strEQ(HEK_KEY(gvhek), "nil")
2796              && stashek && HEK_LEN(stashek) == 8
2797              && strEQ(HEK_KEY(stashek), "overload")) {
2798                 /* This is a hack to support autoloading..., while
2799                    knowing *which* methods were declared as overloaded. */
2800                 /* GvSV contains the name of the method. */
2801                 GV *ngv = NULL;
2802                 SV *gvsv = GvSV(gv);
2803
2804                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\
2805                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2806                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2807                 if (!gvsv || !SvPOK(gvsv)
2808                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2809                 {
2810                     /* Can be an import stub (created by "can"). */
2811                     if (destructing) {
2812                         return -1;
2813                     }
2814                     else {
2815                         const SV * const name = (gvsv && SvPOK(gvsv))
2816                                                     ? gvsv
2817                                                     : newSVpvs_flags("???", SVs_TEMP);
2818                         /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2819                         Perl_croak(aTHX_ "%s method \"%" SVf256
2820                                     "\" overloading \"%s\" "\
2821                                     "in package \"%" HEKf256 "\"",
2822                                    (GvCVGEN(gv) ? "Stub found while resolving"
2823                                     : "Can't resolve"),
2824                                    SVfARG(name), cp,
2825                                    HEKfARG(
2826                                         HvNAME_HEK(stash)
2827                                    ));
2828                     }
2829                 }
2830                 cv = GvCV(gv = ngv);
2831             }
2832             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2833                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2834                          GvNAME(CvGV(cv))) );
2835             filled = 1;
2836         } else if (gv) {                /* Autoloaded... */
2837             cv = MUTABLE_CV(gv);
2838             filled = 1;
2839         }
2840         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2841
2842         if (gv) {
2843             switch (i) {
2844             case to_sv_amg:
2845             case to_av_amg:
2846             case to_hv_amg:
2847             case to_gv_amg:
2848             case to_cv_amg:
2849             case nomethod_amg:
2850                 deref_seen = 1;
2851                 break;
2852             }
2853         }
2854     }
2855     if (!deref_seen)
2856         /* none of @{} etc overloaded; we can do $obj->[N] quicker.
2857          * NB - aux var invalid here, HvARRAY() could have been
2858          * reallocated since it was assigned to */
2859         HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
2860
2861     if (filled) {
2862       AMT_AMAGIC_on(&amt);
2863       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2864                                                 (char*)&amt, sizeof(AMT));
2865       return TRUE;
2866     }
2867   }
2868   /* Here we have no table: */
2869  no_table:
2870   AMT_AMAGIC_off(&amt);
2871   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2872                                                 (char*)&amt, sizeof(AMTS));
2873   return 0;
2874 }
2875
2876
2877 CV*
2878 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2879 {
2880     MAGIC *mg;
2881     AMT *amtp;
2882     U32 newgen;
2883     struct mro_meta* stash_meta;
2884
2885     if (!stash || !HvNAME_get(stash))
2886         return NULL;
2887
2888     stash_meta = HvMROMETA(stash);
2889     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2890
2891     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2892     if (!mg) {
2893       do_update:
2894         if (Gv_AMupdate(stash, 0) == -1)
2895             return NULL;
2896         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2897     }
2898     assert(mg);
2899     amtp = (AMT*)mg->mg_ptr;
2900     if ( amtp->was_ok_sub != newgen )
2901         goto do_update;
2902     if (AMT_AMAGIC(amtp)) {
2903         CV * const ret = amtp->table[id];
2904         if (ret && isGV(ret)) {         /* Autoloading stab */
2905             /* Passing it through may have resulted in a warning
2906                "Inherited AUTOLOAD for a non-method deprecated", since
2907                our caller is going through a function call, not a method call.
2908                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2909             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2910
2911             if (gv && GvCV(gv))
2912                 return GvCV(gv);
2913         }
2914         return ret;
2915     }
2916
2917     return NULL;
2918 }
2919
2920
2921 /* Implement tryAMAGICun_MG macro.
2922    Do get magic, then see if the stack arg is overloaded and if so call it.
2923    Flags:
2924         AMGf_set     return the arg using SETs rather than assigning to
2925                      the targ
2926         AMGf_numeric apply sv_2num to the stack arg.
2927 */
2928
2929 bool
2930 Perl_try_amagic_un(pTHX_ int method, int flags) {
2931     dSP;
2932     SV* tmpsv;
2933     SV* const arg = TOPs;
2934
2935     SvGETMAGIC(arg);
2936
2937     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2938                                               AMGf_noright | AMGf_unary
2939                                             | (flags & AMGf_numarg))))
2940     {
2941         if (flags & AMGf_set) {
2942             SETs(tmpsv);
2943         }
2944         else {
2945             dTARGET;
2946             if (SvPADMY(TARG)) {
2947                 sv_setsv(TARG, tmpsv);
2948                 SETTARG;
2949             }
2950             else
2951                 SETs(tmpsv);
2952         }
2953         PUTBACK;
2954         return TRUE;
2955     }
2956
2957     if ((flags & AMGf_numeric) && SvROK(arg))
2958         *sp = sv_2num(arg);
2959     return FALSE;
2960 }
2961
2962
2963 /* Implement tryAMAGICbin_MG macro.
2964    Do get magic, then see if the two stack args are overloaded and if so
2965    call it.
2966    Flags:
2967         AMGf_set     return the arg using SETs rather than assigning to
2968                      the targ
2969         AMGf_assign  op may be called as mutator (eg +=)
2970         AMGf_numeric apply sv_2num to the stack arg.
2971 */
2972
2973 bool
2974 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2975     dSP;
2976     SV* const left = TOPm1s;
2977     SV* const right = TOPs;
2978
2979     SvGETMAGIC(left);
2980     if (left != right)
2981         SvGETMAGIC(right);
2982
2983     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2984         SV * const tmpsv = amagic_call(left, right, method,
2985                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0)
2986                   | (flags & AMGf_numarg));
2987         if (tmpsv) {
2988             if (flags & AMGf_set) {
2989                 (void)POPs;
2990                 SETs(tmpsv);
2991             }
2992             else {
2993                 dATARGET;
2994                 (void)POPs;
2995                 if (opASSIGN || SvPADMY(TARG)) {
2996                     sv_setsv(TARG, tmpsv);
2997                     SETTARG;
2998                 }
2999                 else
3000                     SETs(tmpsv);
3001             }
3002             PUTBACK;
3003             return TRUE;
3004         }
3005     }
3006     if(left==right && SvGMAGICAL(left)) {
3007         SV * const left = sv_newmortal();
3008         *(sp-1) = left;
3009         /* Print the uninitialized warning now, so it includes the vari-
3010            able name. */
3011         if (!SvOK(right)) {
3012             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
3013             sv_setsv_flags(left, &PL_sv_no, 0);
3014         }
3015         else sv_setsv_flags(left, right, 0);
3016         SvGETMAGIC(right);
3017     }
3018     if (flags & AMGf_numeric) {
3019         if (SvROK(TOPm1s))
3020             *(sp-1) = sv_2num(TOPm1s);
3021         if (SvROK(right))
3022             *sp     = sv_2num(right);
3023     }
3024     return FALSE;
3025 }
3026
3027 SV *
3028 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
3029     SV *tmpsv = NULL;
3030     HV *stash;
3031
3032     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
3033
3034     if (!SvAMAGIC(ref))
3035         return ref;
3036     /* return quickly if none of the deref ops are overloaded */
3037     stash = SvSTASH(SvRV(ref));
3038     assert(SvOOK(stash));
3039     if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
3040         return ref;
3041
3042     while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
3043                                 AMGf_noright | AMGf_unary))) {
3044         if (!SvROK(tmpsv))
3045             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
3046         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
3047             /* Bail out if it returns us the same reference.  */
3048             return tmpsv;
3049         }
3050         ref = tmpsv;
3051         if (!SvAMAGIC(ref))
3052             break;
3053     }
3054     return tmpsv ? tmpsv : ref;
3055 }
3056
3057 bool
3058 Perl_amagic_is_enabled(pTHX_ int method)
3059 {
3060       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
3061
3062       assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
3063
3064       if ( !lex_mask || !SvOK(lex_mask) )
3065           /* overloading lexically disabled */
3066           return FALSE;
3067       else if ( lex_mask && SvPOK(lex_mask) ) {
3068           /* we have an entry in the hints hash, check if method has been
3069            * masked by overloading.pm */
3070           STRLEN len;
3071           const int offset = method / 8;
3072           const int bit    = method % 8;
3073           char *pv = SvPV(lex_mask, len);
3074
3075           /* Bit set, so this overloading operator is disabled */
3076           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
3077               return FALSE;
3078       }
3079       return TRUE;
3080 }
3081
3082 SV*
3083 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
3084 {
3085   dVAR;
3086   MAGIC *mg;
3087   CV *cv=NULL;
3088   CV **cvp=NULL, **ocvp=NULL;
3089   AMT *amtp=NULL, *oamtp=NULL;
3090   int off = 0, off1, lr = 0, notfound = 0;
3091   int postpr = 0, force_cpy = 0;
3092   int assign = AMGf_assign & flags;
3093   const int assignshift = assign ? 1 : 0;
3094   int use_default_op = 0;
3095   int force_scalar = 0;
3096 #ifdef DEBUGGING
3097   int fl=0;
3098 #endif
3099   HV* stash=NULL;
3100
3101   PERL_ARGS_ASSERT_AMAGIC_CALL;
3102
3103   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
3104       if (!amagic_is_enabled(method)) return NULL;
3105   }
3106
3107   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
3108       && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
3109       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3110       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3111                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
3112                         : NULL))
3113       && ((cv = cvp[off=method+assignshift])
3114           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
3115                                                           * usual method */
3116                   (
3117 #ifdef DEBUGGING
3118                    fl = 1,
3119 #endif
3120                    cv = cvp[off=method])))) {
3121     lr = -1;                    /* Call method for left argument */
3122   } else {
3123     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
3124       int logic;
3125
3126       /* look for substituted methods */
3127       /* In all the covered cases we should be called with assign==0. */
3128          switch (method) {
3129          case inc_amg:
3130            force_cpy = 1;
3131            if ((cv = cvp[off=add_ass_amg])
3132                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3133              right = &PL_sv_yes; lr = -1; assign = 1;
3134            }
3135            break;
3136          case dec_amg:
3137            force_cpy = 1;
3138            if ((cv = cvp[off = subtr_ass_amg])
3139                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3140              right = &PL_sv_yes; lr = -1; assign = 1;
3141            }
3142            break;
3143          case bool__amg:
3144            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
3145            break;
3146          case numer_amg:
3147            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
3148            break;
3149          case string_amg:
3150            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
3151            break;
3152          case not_amg:
3153            (void)((cv = cvp[off=bool__amg])
3154                   || (cv = cvp[off=numer_amg])
3155                   || (cv = cvp[off=string_amg]));
3156            if (cv)
3157                postpr = 1;
3158            break;
3159          case copy_amg:
3160            {
3161              /*
3162                   * SV* ref causes confusion with the interpreter variable of
3163                   * the same name
3164                   */
3165              SV* const tmpRef=SvRV(left);
3166              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
3167                 /*
3168                  * Just to be extra cautious.  Maybe in some
3169                  * additional cases sv_setsv is safe, too.
3170                  */
3171                 SV* const newref = newSVsv(tmpRef);
3172                 SvOBJECT_on(newref);
3173                 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
3174                    delegate to the stash. */
3175                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
3176                 return newref;
3177              }
3178            }
3179            break;
3180          case abs_amg:
3181            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3182                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
3183              SV* const nullsv=sv_2mortal(newSViv(0));
3184              if (off1==lt_amg) {
3185                SV* const lessp = amagic_call(left,nullsv,
3186                                        lt_amg,AMGf_noright);
3187                logic = SvTRUE(lessp);
3188              } else {
3189                SV* const lessp = amagic_call(left,nullsv,
3190                                        ncmp_amg,AMGf_noright);
3191                logic = (SvNV(lessp) < 0);
3192              }
3193              if (logic) {
3194                if (off==subtr_amg) {
3195                  right = left;
3196                  left = nullsv;
3197                  lr = 1;
3198                }
3199              } else {
3200                return left;
3201              }
3202            }
3203            break;
3204          case neg_amg:
3205            if ((cv = cvp[off=subtr_amg])) {
3206              right = left;
3207              left = sv_2mortal(newSViv(0));
3208              lr = 1;
3209            }
3210            break;
3211          case int_amg:
3212          case iter_amg:                 /* XXXX Eventually should do to_gv. */
3213          case ftest_amg:                /* XXXX Eventually should do to_gv. */
3214          case regexp_amg:
3215              /* FAIL safe */
3216              return NULL;       /* Delegate operation to standard mechanisms. */
3217
3218          case to_sv_amg:
3219          case to_av_amg:
3220          case to_hv_amg:
3221          case to_gv_amg:
3222          case to_cv_amg:
3223              /* FAIL safe */
3224              return left;       /* Delegate operation to standard mechanisms. */
3225
3226          default:
3227            goto not_found;
3228          }
3229          if (!cv) goto not_found;
3230     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3231                && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3232                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3233                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3234                           ? (amtp = (AMT*)mg->mg_ptr)->table
3235                           : NULL))
3236                && (cv = cvp[off=method])) { /* Method for right
3237                                              * argument found */
3238       lr=1;
3239     } else if (((cvp && amtp->fallback > AMGfallNEVER)
3240                 || (ocvp && oamtp->fallback > AMGfallNEVER))
3241                && !(flags & AMGf_unary)) {
3242                                 /* We look for substitution for
3243                                  * comparison operations and
3244                                  * concatenation */
3245       if (method==concat_amg || method==concat_ass_amg
3246           || method==repeat_amg || method==repeat_ass_amg) {
3247         return NULL;            /* Delegate operation to string conversion */
3248       }
3249       off = -1;
3250       switch (method) {
3251          case lt_amg:
3252          case le_amg:
3253          case gt_amg:
3254          case ge_amg:
3255          case eq_amg:
3256          case ne_amg:
3257              off = ncmp_amg;
3258              break;
3259          case slt_amg:
3260          case sle_amg:
3261          case sgt_amg:
3262          case sge_amg:
3263          case seq_amg:
3264          case sne_amg:
3265              off = scmp_amg;
3266              break;
3267          }
3268       if (off != -1) {
3269           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3270               cv = ocvp[off];
3271               lr = -1;
3272           }
3273           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3274               cv = cvp[off];
3275               lr = 1;
3276           }
3277       }
3278       if (cv)
3279           postpr = 1;
3280       else
3281           goto not_found;
3282     } else {
3283     not_found:                  /* No method found, either report or croak */
3284       switch (method) {
3285          case to_sv_amg:
3286          case to_av_amg:
3287          case to_hv_amg:
3288          case to_gv_amg:
3289          case to_cv_amg:
3290              /* FAIL safe */
3291              return left;       /* Delegate operation to standard mechanisms. */
3292       }
3293       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3294         notfound = 1; lr = -1;
3295       } else if (cvp && (cv=cvp[nomethod_amg])) {
3296         notfound = 1; lr = 1;
3297       } else if ((use_default_op =
3298                   (!ocvp || oamtp->fallback >= AMGfallYES)
3299                   && (!cvp || amtp->fallback >= AMGfallYES))
3300                  && !DEBUG_o_TEST) {
3301         /* Skip generating the "no method found" message.  */
3302         return NULL;
3303       } else {
3304         SV *msg;
3305         if (off==-1) off=method;
3306         msg = sv_2mortal(Perl_newSVpvf(aTHX_
3307                       "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf,
3308                       AMG_id2name(method + assignshift),
3309                       (flags & AMGf_unary ? " " : "\n\tleft "),
3310                       SvAMAGIC(left)?
3311                         "in overloaded package ":
3312                         "has no overloaded magic",
3313                       SvAMAGIC(left)?
3314                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3315                         SVfARG(&PL_sv_no),
3316                       SvAMAGIC(right)?
3317                         ",\n\tright argument in overloaded package ":
3318                         (flags & AMGf_unary
3319                          ? ""
3320                          : ",\n\tright argument has no overloaded magic"),
3321                       SvAMAGIC(right)?
3322                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3323                         SVfARG(&PL_sv_no)));
3324         if (use_default_op) {
3325           DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) );
3326         } else {
3327           Perl_croak(aTHX_ "%" SVf, SVfARG(msg));
3328         }
3329         return NULL;
3330       }
3331       force_cpy = force_cpy || assign;
3332     }
3333   }
3334
3335   switch (method) {
3336     /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3337      * operation. we need this to return a value, so that it can be assigned
3338      * later on, in the postpr block (case inc_amg/dec_amg), even if the
3339      * increment or decrement was itself called in void context */
3340     case inc_amg:
3341       if (off == add_amg)
3342         force_scalar = 1;
3343       break;
3344     case dec_amg:
3345       if (off == subtr_amg)
3346         force_scalar = 1;
3347       break;
3348     /* in these cases, we're calling an assignment variant of an operator
3349      * (+= rather than +, for instance). regardless of whether it's a
3350      * fallback or not, it always has to return a value, which will be
3351      * assigned to the proper variable later */
3352     case add_amg:
3353     case subtr_amg:
3354     case mult_amg:
3355     case div_amg:
3356     case modulo_amg:
3357     case pow_amg:
3358     case lshift_amg:
3359     case rshift_amg:
3360     case repeat_amg:
3361     case concat_amg:
3362     case band_amg:
3363     case bor_amg:
3364     case bxor_amg:
3365     case sband_amg:
3366     case sbor_amg:
3367     case sbxor_amg:
3368       if (assign)
3369         force_scalar = 1;
3370       break;
3371     /* the copy constructor always needs to return a value */
3372     case copy_amg:
3373       force_scalar = 1;
3374       break;
3375     /* because of the way these are implemented (they don't perform the
3376      * dereferencing themselves, they return a reference that perl then
3377      * dereferences later), they always have to be in scalar context */
3378     case to_sv_amg:
3379     case to_av_amg:
3380     case to_hv_amg:
3381     case to_gv_amg:
3382     case to_cv_amg:
3383       force_scalar = 1;
3384       break;
3385     /* these don't have an op of their own; they're triggered by their parent
3386      * op, so the context there isn't meaningful ('$a and foo()' in void
3387      * context still needs to pass scalar context on to $a's bool overload) */
3388     case bool__amg:
3389     case numer_amg:
3390     case string_amg:
3391       force_scalar = 1;
3392       break;
3393   }
3394
3395 #ifdef DEBUGGING
3396   if (!notfound) {
3397     DEBUG_o(Perl_deb(aTHX_
3398                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n",
3399                      AMG_id2name(off),
3400                      method+assignshift==off? "" :
3401                      " (initially \"",
3402                      method+assignshift==off? "" :
3403                      AMG_id2name(method+assignshift),
3404                      method+assignshift==off? "" : "\")",
3405                      flags & AMGf_unary? "" :
3406                      lr==1 ? " for right argument": " for left argument",
3407                      flags & AMGf_unary? " for argument" : "",
3408                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3409                      fl? ",\n\tassignment variant used": "") );
3410   }
3411 #endif
3412     /* Since we use shallow copy during assignment, we need
3413      * to dublicate the contents, probably calling user-supplied
3414      * version of copy operator
3415      */
3416     /* We need to copy in following cases:
3417      * a) Assignment form was called.
3418      *          assignshift==1,  assign==T, method + 1 == off
3419      * b) Increment or decrement, called directly.
3420      *          assignshift==0,  assign==0, method + 0 == off
3421      * c) Increment or decrement, translated to assignment add/subtr.
3422      *          assignshift==0,  assign==T,
3423      *          force_cpy == T
3424      * d) Increment or decrement, translated to nomethod.
3425      *          assignshift==0,  assign==0,
3426      *          force_cpy == T
3427      * e) Assignment form translated to nomethod.
3428      *          assignshift==1,  assign==T, method + 1 != off
3429      *          force_cpy == T
3430      */
3431     /*  off is method, method+assignshift, or a result of opcode substitution.
3432      *  In the latter case assignshift==0, so only notfound case is important.
3433      */
3434   if ( (lr == -1) && ( ( (method + assignshift == off)
3435         && (assign || (method == inc_amg) || (method == dec_amg)))
3436       || force_cpy) )
3437   {
3438       /* newSVsv does not behave as advertised, so we copy missing
3439        * information by hand */
3440       SV *tmpRef = SvRV(left);
3441       SV *rv_copy;
3442       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3443           SvRV_set(left, rv_copy);
3444           SvSETMAGIC(left);
3445           SvREFCNT_dec_NN(tmpRef);
3446       }
3447   }
3448
3449   {
3450     dSP;
3451     BINOP myop;
3452     SV* res;
3453     const bool oldcatch = CATCH_GET;
3454     I32 oldmark, nret;
3455     U8 gimme = force_scalar ? G_SCALAR : GIMME_V;
3456
3457     CATCH_SET(TRUE);
3458     Zero(&myop, 1, BINOP);
3459     myop.op_last = (OP *) &myop;
3460     myop.op_next = NULL;
3461     myop.op_flags = OPf_STACKED;
3462
3463     switch (gimme) {
3464         case G_VOID:
3465             myop.op_flags |= OPf_WANT_VOID;
3466             break;
3467         case G_ARRAY:
3468             if (flags & AMGf_want_list) {
3469                 myop.op_flags |= OPf_WANT_LIST;
3470                 break;
3471             }
3472             /* FALLTHROUGH */
3473         default:
3474             myop.op_flags |= OPf_WANT_SCALAR;
3475             break;
3476     }
3477
3478     PUSHSTACKi(PERLSI_OVERLOAD);
3479     ENTER;
3480     SAVEOP();
3481     PL_op = (OP *) &myop;
3482     if (PERLDB_SUB && PL_curstash != PL_debstash)
3483         PL_op->op_private |= OPpENTERSUB_DB;
3484     Perl_pp_pushmark(aTHX);
3485
3486     EXTEND(SP, notfound + 5);
3487     PUSHs(lr>0? right: left);
3488     PUSHs(lr>0? left: right);
3489     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3490     if (notfound) {
3491       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3492                            AMG_id2namelen(method + assignshift), SVs_TEMP));
3493     }
3494     else if (flags & AMGf_numarg)
3495       PUSHs(&PL_sv_undef);
3496     if (flags & AMGf_numarg)
3497       PUSHs(&PL_sv_yes);
3498     PUSHs(MUTABLE_SV(cv));
3499     PUTBACK;
3500     oldmark = TOPMARK;
3501
3502     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3503       CALLRUNOPS(aTHX);
3504     LEAVE;
3505     SPAGAIN;
3506     nret = SP - (PL_stack_base + oldmark);
3507
3508     switch (gimme) {
3509         case G_VOID:
3510             /* returning NULL has another meaning, and we check the context
3511              * at the call site too, so this can be differentiated from the
3512              * scalar case */
3513             res = &PL_sv_undef;
3514             SP = PL_stack_base + oldmark;
3515             break;
3516         case G_ARRAY: {
3517             if (flags & AMGf_want_list) {
3518                 res = sv_2mortal((SV *)newAV());
3519                 av_extend((AV *)res, nret);
3520                 while (nret--)
3521                     av_store((AV *)res, nret, POPs);
3522                 break;
3523             }
3524             /* FALLTHROUGH */
3525         }
3526         default:
3527             res = POPs;
3528             break;
3529     }
3530
3531     PUTBACK;
3532     POPSTACK;
3533     CATCH_SET(oldcatch);
3534
3535     if (postpr) {
3536       int ans;
3537       switch (method) {
3538       case le_amg:
3539       case sle_amg:
3540         ans=SvIV(res)<=0; break;
3541       case lt_amg:
3542       case slt_amg:
3543         ans=SvIV(res)<0; break;
3544       case ge_amg:
3545       case sge_amg:
3546         ans=SvIV(res)>=0; break;
3547       case gt_amg:
3548       case sgt_amg:
3549         ans=SvIV(res)>0; break;
3550       case eq_amg:
3551       case seq_amg:
3552         ans=SvIV(res)==0; break;
3553       case ne_amg:
3554       case sne_amg:
3555         ans=SvIV(res)!=0; break;
3556       case inc_amg:
3557       case dec_amg:
3558         SvSetSV(left,res); return left;
3559       case not_amg:
3560         ans=!SvTRUE(res); break;
3561       default:
3562         ans=0; break;
3563       }
3564       return boolSV(ans);
3565     } else if (method==copy_amg) {
3566       if (!SvROK(res)) {
3567         Perl_croak(aTHX_ "Copy method did not return a reference");
3568       }
3569       return SvREFCNT_inc(SvRV(res));
3570     } else {
3571       return res;
3572     }
3573   }
3574 }
3575
3576 void
3577 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3578 {
3579     dVAR;
3580     U32 hash;
3581
3582     PERL_ARGS_ASSERT_GV_NAME_SET;
3583
3584     if (len > I32_MAX)
3585         Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len);
3586
3587     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3588         unshare_hek(GvNAME_HEK(gv));
3589     }
3590
3591     PERL_HASH(hash, name, len);
3592     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3593 }
3594
3595 /*
3596 =for apidoc gv_try_downgrade
3597
3598 If the typeglob C<gv> can be expressed more succinctly, by having
3599 something other than a real GV in its place in the stash, replace it
3600 with the optimised form.  Basic requirements for this are that C<gv>
3601 is a real typeglob, is sufficiently ordinary, and is only referenced
3602 from its package.  This function is meant to be used when a GV has been
3603 looked up in part to see what was there, causing upgrading, but based
3604 on what was found it turns out that the real GV isn't required after all.
3605
3606 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3607
3608 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3609 sub, the typeglob is replaced with a scalar-reference placeholder that
3610 more compactly represents the same thing.
3611
3612 =cut
3613 */
3614
3615 void
3616 Perl_gv_try_downgrade(pTHX_ GV *gv)
3617 {
3618     HV *stash;
3619     CV *cv;
3620     HEK *namehek;
3621     SV **gvp;
3622     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3623
3624     /* XXX Why and where does this leave dangling pointers during global
3625        destruction? */
3626     if (PL_phase == PERL_PHASE_DESTRUCT) return;
3627
3628     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3629             !SvOBJECT(gv) && !SvREADONLY(gv) &&
3630             isGV_with_GP(gv) && GvGP(gv) &&
3631             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3632             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3633             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3634         return;
3635     if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3636         return;
3637     if (SvMAGICAL(gv)) {
3638         MAGIC *mg;
3639         /* only backref magic is allowed */
3640         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3641             return;
3642         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3643             if (mg->mg_type != PERL_MAGIC_backref)
3644                 return;
3645         }
3646     }
3647     cv = GvCV(gv);
3648     if (!cv) {
3649         HEK *gvnhek = GvNAME_HEK(gv);
3650         (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3651     } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3652             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3653             CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
3654             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3655             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3656             (namehek = GvNAME_HEK(gv)) &&
3657             (gvp = hv_fetchhek(stash, namehek, 0)) &&
3658             *gvp == (SV*)gv) {
3659         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3660         const bool imported = !!GvIMPORTED_CV(gv);
3661         SvREFCNT(gv) = 0;
3662         sv_clear((SV*)gv);
3663         SvREFCNT(gv) = 1;
3664         SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3665
3666         /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
3667         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3668                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3669         SvRV_set(gv, value);
3670     }
3671 }
3672
3673 GV *
3674 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3675 {
3676     GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3677     GV * const *gvp;
3678     PERL_ARGS_ASSERT_GV_OVERRIDE;
3679     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3680     gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3681     gv = gvp ? *gvp : NULL;
3682     if (gv && !isGV(gv)) {
3683         if (!SvPCS_IMPORTED(gv)) return NULL;
3684         gv_init(gv, PL_globalstash, name, len, 0);
3685         return gv;
3686     }
3687     return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3688 }
3689
3690 #include "XSUB.h"
3691
3692 static void
3693 core_xsub(pTHX_ CV* cv)
3694 {
3695     Perl_croak(aTHX_
3696        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3697     );
3698 }
3699
3700 /*
3701  * ex: set ts=8 sts=4 sw=4 et:
3702  */