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