gv.c

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