gv.c

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