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