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