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