gv.c

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