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