gv.c

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