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