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