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