gv.c

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