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