gv.c

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