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
  25 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
  26 It is a structure that holds a pointer to a scalar, an array, a hash etc,
  27 corresponding to $foo, @foo, %foo.
  28
  29 GVs are usually found as values in stashes (symbol table hashes) where
  30 Perl stores its global variables.
  31
  32 =cut
  33 */
  34
  35 #include "EXTERN.h"
  36 #define PERL_IN_GV_C
  37 #include "perl.h"
  38 #include "overload.c"
  39 #include "keywords.h"
  40
  41 static const char S_autoload[] = "AUTOLOAD";
  42 static const STRLEN S_autolen = sizeof(S_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             /* diag_listed_as: Bad symbol for filehandle */
  65         } else if (type == SVt_PVHV) {
  66             what = "hash";
  67         } else {
  68             what = type == SVt_PVAV ? "array" : "scalar";
  69         }
  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         *where = newSV_type(type);
  85     return gv;
  86 }
  87
  88 GV *
  89 Perl_gv_fetchfile(pTHX_ const char *name)
  90 {
  91     PERL_ARGS_ASSERT_GV_FETCHFILE;
  92     return gv_fetchfile_flags(name, strlen(name), 0);
  93 }
  94
  95 GV *
  96 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
  97                         const U32 flags)
  98 {
  99     dVAR;
 100     char smallbuf[128];
 101     char *tmpbuf;
 102     const STRLEN tmplen = namelen + 2;
 103     GV *gv;
 104
 105     PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
 106     PERL_UNUSED_ARG(flags);
 107
 108     if (!PL_defstash)
 109         return NULL;
 110
 111     if (tmplen <= sizeof smallbuf)
 112         tmpbuf = smallbuf;
 113     else
 114         Newx(tmpbuf, tmplen, char);
 115     /* This is where the debugger's %{"::_<$filename"} hash is created */
 116     tmpbuf[0] = '_';
 117     tmpbuf[1] = '<';
 118     memcpy(tmpbuf + 2, name, namelen);
 119     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
 120     if (!isGV(gv)) {
 121         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
 122 #ifdef PERL_DONT_CREATE_GVSV
 123         GvSV(gv) = newSVpvn(name, namelen);
 124 #else
 125         sv_setpvn(GvSV(gv), name, namelen);
 126 #endif
 127     }
 128     if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
 129             hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
 130     if (tmpbuf != smallbuf)
 131         Safefree(tmpbuf);
 132     return gv;
 133 }
 134
 135 /*
 136 =for apidoc gv_const_sv
 137
 138 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
 139 inlining, or C<gv> is a placeholder reference that would be promoted to such
 140 a typeglob, then returns the value returned by the sub.  Otherwise, returns
 141 NULL.
 142
 143 =cut
 144 */
 145
 146 SV *
 147 Perl_gv_const_sv(pTHX_ GV *gv)
 148 {
 149     PERL_ARGS_ASSERT_GV_CONST_SV;
 150
 151     if (SvTYPE(gv) == SVt_PVGV)
 152         return cv_const_sv(GvCVu(gv));
 153     return SvROK(gv) ? SvRV(gv) : NULL;
 154 }
 155
 156 GP *
 157 Perl_newGP(pTHX_ GV *const gv)
 158 {
 159     GP *gp;
 160     U32 hash;
 161 #ifdef USE_ITHREADS
 162     const char *const file
 163         = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
 164     const STRLEN len = strlen(file);
 165 #else
 166     SV *const temp_sv = CopFILESV(PL_curcop);
 167     const char *file;
 168     STRLEN len;
 169
 170     PERL_ARGS_ASSERT_NEWGP;
 171
 172     if (temp_sv) {
 173         file = SvPVX(temp_sv);
 174         len = SvCUR(temp_sv);
 175     } else {
 176         file = "";
 177         len = 0;
 178     }
 179 #endif
 180
 181     PERL_HASH(hash, file, len);
 182
 183     Newxz(gp, 1, GP);
 184
 185 #ifndef PERL_DONT_CREATE_GVSV
 186     gp->gp_sv = newSV(0);
 187 #endif
 188
 189     gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
 190     /* XXX Ideally this cast would be replaced with a change to const char*
 191        in the struct.  */
 192     gp->gp_file_hek = share_hek(file, len, hash);
 193     gp->gp_egv = gv;
 194     gp->gp_refcnt = 1;
 195
 196     return gp;
 197 }
 198
 199 /* Assign CvGV(cv) = gv, handling weak references.
 200  * See also S_anonymise_cv_maybe */
 201
 202 void
 203 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
 204 {
 205     GV * const oldgv = CvGV(cv);
 206     PERL_ARGS_ASSERT_CVGV_SET;
 207
 208     if (oldgv == gv)
 209         return;
 210
 211     if (oldgv) {
 212         if (CvCVGV_RC(cv)) {
 213             SvREFCNT_dec(oldgv);
 214             CvCVGV_RC_off(cv);
 215         }
 216         else {
 217             sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
 218         }
 219     }
 220
 221     SvANY(cv)->xcv_gv = gv;
 222     assert(!CvCVGV_RC(cv));
 223
 224     if (!gv)
 225         return;
 226
 227     if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
 228         Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
 229     else {
 230         CvCVGV_RC_on(cv);
 231         SvREFCNT_inc_simple_void_NN(gv);
 232     }
 233 }
 234
 235 /* Assign CvSTASH(cv) = st, handling weak references. */
 236
 237 void
 238 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
 239 {
 240     HV *oldst = CvSTASH(cv);
 241     PERL_ARGS_ASSERT_CVSTASH_SET;
 242     if (oldst == st)
 243         return;
 244     if (oldst)
 245         sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
 246     SvANY(cv)->xcv_stash = st;
 247     if (st)
 248         Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
 249 }
 250
 251 /*
 252 =for apidoc gv_init_pvn
 253
 254 Converts a scalar into a typeglob.  This is an incoercible typeglob;
 255 assigning a reference to it will assign to one of its slots, instead of
 256 overwriting it as happens with typeglobs created by SvSetSV.  Converting
 257 any scalar that is SvOK() may produce unpredictable results and is reserved
 258 for perl's internal use.
 259
 260 C<gv> is the scalar to be converted.
 261
 262 C<stash> is the parent stash/package, if any.
 263
 264 C<name> and C<len> give the name.  The name must be unqualified;
 265 that is, it must not include the package name.  If C<gv> is a
 266 stash element, it is the caller's responsibility to ensure that the name
 267 passed to this function matches the name of the element.  If it does not
 268 match, perl's internal bookkeeping will get out of sync.
 269
 270 C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
 271 the return value of SvUTF8(sv).  It can also take the
 272 GV_ADDMULTI flag, which means to pretend that the GV has been
 273 seen before (i.e., suppress "Used once" warnings).
 274
 275 =for apidoc gv_init
 276
 277 The old form of gv_init_pvn().  It does not work with UTF8 strings, as it
 278 has no flags parameter.  If the C<multi> parameter is set, the
 279 GV_ADDMULTI flag will be passed to gv_init_pvn().
 280
 281 =for apidoc gv_init_pv
 282
 283 Same as gv_init_pvn(), but takes a nul-terminated string for the name
 284 instead of separate char * and length parameters.
 285
 286 =for apidoc gv_init_sv
 287
 288 Same as gv_init_pvn(), but takes an SV * for the name instead of separate
 289 char * and length parameters.  C<flags> is currently unused.
 290
 291 =cut
 292 */
 293
 294 void
 295 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
 296 {
 297    char *namepv;
 298    STRLEN namelen;
 299    PERL_ARGS_ASSERT_GV_INIT_SV;
 300    namepv = SvPV(namesv, namelen);
 301    if (SvUTF8(namesv))
 302        flags |= SVf_UTF8;
 303    gv_init_pvn(gv, stash, namepv, namelen, flags);
 304 }
 305
 306 void
 307 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
 308 {
 309    PERL_ARGS_ASSERT_GV_INIT_PV;
 310    gv_init_pvn(gv, stash, name, strlen(name), flags);
 311 }
 312
 313 void
 314 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
 315 {
 316     dVAR;
 317     const U32 old_type = SvTYPE(gv);
 318     const bool doproto = old_type > SVt_NULL;
 319     char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
 320     const STRLEN protolen = proto ? SvCUR(gv) : 0;
 321     const U32 proto_utf8  = proto ? SvUTF8(gv) : 0;
 322     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
 323     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
 324
 325     PERL_ARGS_ASSERT_GV_INIT_PVN;
 326     assert (!(proto && has_constant));
 327
 328     if (has_constant) {
 329         /* The constant has to be a simple scalar type.  */
 330         switch (SvTYPE(has_constant)) {
 331         case SVt_PVAV:
 332         case SVt_PVHV:
 333         case SVt_PVCV:
 334         case SVt_PVFM:
 335         case SVt_PVIO:
 336             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
 337                        sv_reftype(has_constant, 0));
 338         default: NOOP;
 339         }
 340         SvRV_set(gv, NULL);
 341         SvROK_off(gv);
 342     }
 343
 344
 345     if (old_type < SVt_PVGV) {
 346         if (old_type >= SVt_PV)
 347             SvCUR_set(gv, 0);
 348         sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
 349     }
 350     if (SvLEN(gv)) {
 351         if (proto) {
 352             SvPV_set(gv, NULL);
 353             SvLEN_set(gv, 0);
 354             SvPOK_off(gv);
 355         } else
 356             Safefree(SvPVX_mutable(gv));
 357     }
 358     SvIOK_off(gv);
 359     isGV_with_GP_on(gv);
 360
 361     GvGP_set(gv, Perl_newGP(aTHX_ gv));
 362     GvSTASH(gv) = stash;
 363     if (stash)
 364         Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
 365     gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
 366     if (flags & GV_ADDMULTI || doproto) /* doproto means it */
 367         GvMULTI_on(gv);                 /* _was_ mentioned */
 368     if (doproto) {                      /* Replicate part of newSUB here. */
 369         CV *cv;
 370         ENTER;
 371         if (has_constant) {
 372             char *name0 = NULL;
 373             if (name[len])
 374                 /* newCONSTSUB doesn't take a len arg, so make sure we
 375                  * give it a \0-terminated string */
 376                 name0 = savepvn(name,len);
 377
 378             /* newCONSTSUB takes ownership of the reference from us.  */
 379             cv = newCONSTSUB_flags(stash, (name0 ? name0 : name), flags, has_constant);
 380             /* In case op.c:S_process_special_blocks stole it: */
 381             if (!GvCV(gv))
 382                 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
 383             assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
 384             if (name0)
 385                 Safefree(name0);
 386             /* If this reference was a copy of another, then the subroutine
 387                must have been "imported", by a Perl space assignment to a GV
 388                from a reference to CV.  */
 389             if (exported_constant)
 390                 GvIMPORTED_CV_on(gv);
 391         } else {
 392             (void) start_subparse(0,0); /* Create empty CV in compcv. */
 393             cv = PL_compcv;
 394             GvCV_set(gv,cv);
 395         }
 396         LEAVE;
 397
 398         mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
 399         CvGV_set(cv, gv);
 400         CvFILE_set_from_cop(cv, PL_curcop);
 401         CvSTASH_set(cv, PL_curstash);
 402         if (proto) {
 403             sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
 404                             SV_HAS_TRAILING_NUL);
 405             if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
 406         }
 407     }
 408 }
 409
 410 STATIC void
 411 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
 412 {
 413     PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
 414
 415     switch (sv_type) {
 416     case SVt_PVIO:
 417         (void)GvIOn(gv);
 418         break;
 419     case SVt_PVAV:
 420         (void)GvAVn(gv);
 421         break;
 422     case SVt_PVHV:
 423         (void)GvHVn(gv);
 424         break;
 425 #ifdef PERL_DONT_CREATE_GVSV
 426     case SVt_NULL:
 427     case SVt_PVCV:
 428     case SVt_PVFM:
 429     case SVt_PVGV:
 430         break;
 431     default:
 432         if(GvSVn(gv)) {
 433             /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
 434                If we just cast GvSVn(gv) to void, it ignores evaluating it for
 435                its side effect */
 436         }
 437 #endif
 438     }
 439 }
 440
 441 static void core_xsub(pTHX_ CV* cv);
 442
 443 static GV *
 444 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
 445                           const char * const name, const STRLEN len,
 446                           const char * const fullname, STRLEN const fullen)
 447 {
 448     const int code = keyword(name, len, 1);
 449     static const char file[] = __FILE__;
 450     CV *cv, *oldcompcv;
 451     int opnum = 0;
 452     SV *opnumsv;
 453     bool ampable = TRUE; /* &{}-able */
 454     COP *oldcurcop;
 455     yy_parser *oldparser;
 456     I32 oldsavestack_ix;
 457
 458     assert(gv || stash);
 459     assert(name);
 460     assert(stash || fullname);
 461
 462     if (!fullname && !HvENAME(stash)) return NULL; /* pathological case
 463                                                      that would require
 464                                                     inlining newATTRSUB */
 465     if (code >= 0) return NULL; /* not overridable */
 466     switch (-code) {
 467      /* no support for \&CORE::infix;
 468         no support for funcs that take labels, as their parsing is
 469         weird  */
 470     case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
 471     case KEY_eq: case KEY_ge:
 472     case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
 473     case KEY_or: case KEY_x: case KEY_xor:
 474         return NULL;
 475     case KEY_chdir:
 476     case KEY_chomp: case KEY_chop:
 477     case KEY_each: case KEY_eof: case KEY_exec:
 478     case KEY_keys:
 479     case KEY_lstat:
 480     case KEY_pop:
 481     case KEY_push:
 482     case KEY_shift:
 483     case KEY_splice:
 484     case KEY_stat:
 485     case KEY_system:
 486     case KEY_truncate: case KEY_unlink:
 487     case KEY_unshift:
 488     case KEY_values:
 489         ampable = FALSE;
 490     }
 491     if (!gv) {
 492         gv = (GV *)newSV(0);
 493         gv_init(gv, stash, name, len, TRUE);
 494     }
 495     if (ampable) {
 496         ENTER;
 497         oldcurcop = PL_curcop;
 498         oldparser = PL_parser;
 499         lex_start(NULL, NULL, 0);
 500         oldcompcv = PL_compcv;
 501         PL_compcv = NULL; /* Prevent start_subparse from setting
 502                              CvOUTSIDE. */
 503         oldsavestack_ix = start_subparse(FALSE,0);
 504         cv = PL_compcv;
 505     }
 506     else {
 507         /* Avoid calling newXS, as it calls us, and things start to
 508            get hairy. */
 509         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
 510         GvCV_set(gv,cv);
 511         GvCVGEN(gv) = 0;
 512         mro_method_changed_in(GvSTASH(gv));
 513         CvISXSUB_on(cv);
 514         CvXSUB(cv) = core_xsub;
 515     }
 516     CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
 517                          from PL_curcop. */
 518     (void)gv_fetchfile(file);
 519     CvFILE(cv) = (char *)file;
 520     /* XXX This is inefficient, as doing things this order causes
 521            a prototype check in newATTRSUB.  But we have to do
 522            it this order as we need an op number before calling
 523            new ATTRSUB. */
 524     (void)core_prototype((SV *)cv, name, code, &opnum);
 525     if (stash && (fullname || !fullen))
 526         (void)hv_store(stash,name,len,(SV *)gv,0);
 527     if (ampable) {
 528         SV *tmpstr;
 529         CvLVALUE_on(cv);
 530         if (!fullname) {
 531             tmpstr = newSVhek(HvENAME_HEK(stash));
 532             sv_catpvs(tmpstr, "::");
 533             sv_catpvn(tmpstr,name,len);
 534         }
 535         else tmpstr = newSVpvn_share(fullname,fullen,0);
 536         newATTRSUB(oldsavestack_ix,
 537                    newSVOP(OP_CONST, 0, tmpstr),
 538                    NULL,NULL,
 539                    coresub_op(
 540                      opnum
 541                        ? newSVuv((UV)opnum)
 542                        : newSVpvn(name,len),
 543                      code, opnum
 544                    )
 545         );
 546         assert(GvCV(gv) == cv);
 547         if (opnum != OP_VEC && opnum != OP_SUBSTR)
 548             CvLVALUE_off(cv); /* Now *that* was a neat trick. */
 549         LEAVE;
 550         PL_parser = oldparser;
 551         PL_curcop = oldcurcop;
 552         PL_compcv = oldcompcv;
 553     }
 554     opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
 555     cv_set_call_checker(
 556        cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
 557     );
 558     SvREFCNT_dec(opnumsv);
 559     return gv;
 560 }
 561
 562 /*
 563 =for apidoc gv_fetchmeth
 564
 565 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
 566
 567 =for apidoc gv_fetchmeth_sv
 568
 569 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
 570 of an SV instead of a string/length pair.
 571
 572 =cut
 573 */
 574
 575 GV *
 576 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
 577 {
 578    char *namepv;
 579    STRLEN namelen;
 580    PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
 581    namepv = SvPV(namesv, namelen);
 582    if (SvUTF8(namesv))
 583        flags |= SVf_UTF8;
 584    return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
 585 }
 586
 587 /*
 588 =for apidoc gv_fetchmeth_pv
 589
 590 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
 591 instead of a string/length pair.
 592
 593 =cut
 594 */
 595
 596 GV *
 597 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
 598 {
 599     PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
 600     return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags);
 601 }
 602
 603 /*
 604 =for apidoc gv_fetchmeth_pvn
 605
 606 Returns the glob with the given C<name> and a defined subroutine or
 607 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
 608 accessible via @ISA and UNIVERSAL::.
 609
 610 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 611 side-effect creates a glob with the given C<name> in the given C<stash>
 612 which in the case of success contains an alias for the subroutine, and sets
 613 up caching info for this glob.
 614
 615 Currently, the only significant value for C<flags> is SVf_UTF8.
 616
 617 This function grants C<"SUPER"> token as a postfix of the stash name. The
 618 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 619 visible to Perl code.  So when calling C<call_sv>, you should not use
 620 the GV directly; instead, you should use the method's CV, which can be
 621 obtained from the GV with the C<GvCV> macro.
 622
 623 =cut
 624 */
 625
 626 /* NOTE: No support for tied ISA */
 627
 628 GV *
 629 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
 630 {
 631     dVAR;
 632     GV** gvp;
 633     AV* linear_av;
 634     SV** linear_svp;
 635     SV* linear_sv;
 636     HV* cstash;
 637     GV* candidate = NULL;
 638     CV* cand_cv = NULL;
 639     GV* topgv = NULL;
 640     const char *hvname;
 641     I32 create = (level >= 0) ? 1 : 0;
 642     I32 items;
 643     STRLEN packlen;
 644     U32 topgen_cmp;
 645     U32 is_utf8 = flags & SVf_UTF8;
 646
 647     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
 648
 649     /* UNIVERSAL methods should be callable without a stash */
 650     if (!stash) {
 651         create = 0;  /* probably appropriate */
 652         if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
 653             return 0;
 654     }
 655
 656     assert(stash);
 657
 658     hvname = HvNAME_get(stash);
 659     if (!hvname)
 660       Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 661
 662     assert(hvname);
 663     assert(name);
 664
 665     DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
 666
 667     topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
 668
 669     /* check locally for a real method or a cache entry */
 670     gvp = (GV**)hv_fetch(stash, name, is_utf8 ? -(I32)len : (I32)len, create);
 671     if(gvp) {
 672         topgv = *gvp;
 673       have_gv:
 674         assert(topgv);
 675         if (SvTYPE(topgv) != SVt_PVGV)
 676             gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
 677         if ((cand_cv = GvCV(topgv))) {
 678             /* If genuine method or valid cache entry, use it */
 679             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
 680                 return topgv;
 681             }
 682             else {
 683                 /* stale cache entry, junk it and move on */
 684                 SvREFCNT_dec(cand_cv);
 685                 GvCV_set(topgv, NULL);
 686                 cand_cv = NULL;
 687                 GvCVGEN(topgv) = 0;
 688             }
 689         }
 690         else if (GvCVGEN(topgv) == topgen_cmp) {
 691             /* cache indicates no such method definitively */
 692             return 0;
 693         }
 694         else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
 695               && strnEQ(hvname, "CORE", 4)
 696               && S_maybe_add_coresub(aTHX_ stash,topgv,name,len,0,1))
 697             goto have_gv;
 698     }
 699
 700     packlen = HvNAMELEN_get(stash);
 701     if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
 702         HV* basestash;
 703         packlen -= 7;
 704         basestash = gv_stashpvn(hvname, packlen,
 705                                 GV_ADD | (HvNAMEUTF8(stash) ? SVf_UTF8 : 0));
 706         linear_av = mro_get_linear_isa(basestash);
 707     }
 708     else {
 709         linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
 710     }
 711
 712     linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
 713     items = AvFILLp(linear_av); /* no +1, to skip over self */
 714     while (items--) {
 715         linear_sv = *linear_svp++;
 716         assert(linear_sv);
 717         cstash = gv_stashsv(linear_sv, 0);
 718
 719         if (!cstash) {
 720             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
 721                            "Can't locate package %"SVf" for @%"SVf"::ISA",
 722                            SVfARG(linear_sv),
 723                            SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))));
 724             continue;
 725         }
 726
 727         assert(cstash);
 728
 729         gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
 730         if (!gvp) {
 731             if (len > 1 && HvNAMELEN_get(cstash) == 4) {
 732                 const char *hvname = HvNAME(cstash); assert(hvname);
 733                 if (strnEQ(hvname, "CORE", 4)
 734                  && (candidate =
 735                       S_maybe_add_coresub(aTHX_ cstash,NULL,name,len,0,0)
 736                     ))
 737                     goto have_candidate;
 738             }
 739             continue;
 740         }
 741         else candidate = *gvp;
 742        have_candidate:
 743         assert(candidate);
 744         if (SvTYPE(candidate) != SVt_PVGV)
 745             gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
 746         if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 747             /*
 748              * Found real method, cache method in topgv if:
 749              *  1. topgv has no synonyms (else inheritance crosses wires)
 750              *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 751              */
 752             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 753                   CV *old_cv = GvCV(topgv);
 754                   SvREFCNT_dec(old_cv);
 755                   SvREFCNT_inc_simple_void_NN(cand_cv);
 756                   GvCV_set(topgv, cand_cv);
 757                   GvCVGEN(topgv) = topgen_cmp;
 758             }
 759             return candidate;
 760         }
 761     }
 762
 763     /* Check UNIVERSAL without caching */
 764     if(level == 0 || level == -1) {
 765         candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags);
 766         if(candidate) {
 767             cand_cv = GvCV(candidate);
 768             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 769                   CV *old_cv = GvCV(topgv);
 770                   SvREFCNT_dec(old_cv);
 771                   SvREFCNT_inc_simple_void_NN(cand_cv);
 772                   GvCV_set(topgv, cand_cv);
 773                   GvCVGEN(topgv) = topgen_cmp;
 774             }
 775             return candidate;
 776         }
 777     }
 778
 779     if (topgv && GvREFCNT(topgv) == 1) {
 780         /* cache the fact that the method is not defined */
 781         GvCVGEN(topgv) = topgen_cmp;
 782     }
 783
 784     return 0;
 785 }
 786
 787 /*
 788 =for apidoc gv_fetchmeth_autoload
 789
 790 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
 791 parameter.
 792
 793 =for apidoc gv_fetchmeth_sv_autoload
 794
 795 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
 796 of an SV instead of a string/length pair.
 797
 798 =cut
 799 */
 800
 801 GV *
 802 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
 803 {
 804    char *namepv;
 805    STRLEN namelen;
 806    PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
 807    namepv = SvPV(namesv, namelen);
 808    if (SvUTF8(namesv))
 809        flags |= SVf_UTF8;
 810    return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
 811 }
 812
 813 /*
 814 =for apidoc gv_fetchmeth_pv_autoload
 815
 816 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
 817 instead of a string/length pair.
 818
 819 =cut
 820 */
 821
 822 GV *
 823 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
 824 {
 825     PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
 826     return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
 827 }
 828
 829 /*
 830 =for apidoc gv_fetchmeth_pvn_autoload
 831
 832 Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
 833 Returns a glob for the subroutine.
 834
 835 For an autoloaded subroutine without a GV, will create a GV even
 836 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
 837 of the result may be zero.
 838
 839 Currently, the only significant value for C<flags> is SVf_UTF8.
 840
 841 =cut
 842 */
 843
 844 GV *
 845 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
 846 {
 847     GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
 848
 849     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
 850
 851     if (!gv) {
 852         CV *cv;
 853         GV **gvp;
 854
 855         if (!stash)
 856             return NULL;        /* UNIVERSAL::AUTOLOAD could cause trouble */
 857         if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
 858             return NULL;
 859         if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
 860             return NULL;
 861         cv = GvCV(gv);
 862         if (!(CvROOT(cv) || CvXSUB(cv)))
 863             return NULL;
 864         /* Have an autoload */
 865         if (level < 0)  /* Cannot do without a stub */
 866             gv_fetchmeth_pvn(stash, name, len, 0, flags);
 867         gvp = (GV**)hv_fetch(stash, name,
 868                         (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
 869         if (!gvp)
 870             return NULL;
 871         return *gvp;
 872     }
 873     return gv;
 874 }
 875
 876 /*
 877 =for apidoc gv_fetchmethod_autoload
 878
 879 Returns the glob which contains the subroutine to call to invoke the method
 880 on the C<stash>.  In fact in the presence of autoloading this may be the
 881 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
 882 already setup.
 883
 884 The third parameter of C<gv_fetchmethod_autoload> determines whether
 885 AUTOLOAD lookup is performed if the given method is not present: non-zero
 886 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
 887 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
 888 with a non-zero C<autoload> parameter.
 889
 890 These functions grant C<"SUPER"> token as a prefix of the method name. Note
 891 that if you want to keep the returned glob for a long time, you need to
 892 check for it being "AUTOLOAD", since at the later time the call may load a
 893 different subroutine due to $AUTOLOAD changing its value. Use the glob
 894 created via a side effect to do this.
 895
 896 These functions have the same side-effects and as C<gv_fetchmeth> with
 897 C<level==0>.  C<name> should be writable if contains C<':'> or C<'
 898 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
 899 C<call_sv> apply equally to these functions.
 900
 901 =cut
 902 */
 903
 904 STATIC HV*
 905 S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags)
 906 {
 907     AV* superisa;
 908     GV** gvp;
 909     GV* gv;
 910     HV* stash;
 911
 912     PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
 913
 914     stash = gv_stashpvn(name, namelen, flags);
 915     if(stash) return stash;
 916
 917     /* If we must create it, give it an @ISA array containing
 918        the real package this SUPER is for, so that it's tied
 919        into the cache invalidation code correctly */
 920     stash = gv_stashpvn(name, namelen, GV_ADD | flags);
 921     gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
 922     gv = *gvp;
 923     gv_init(gv, stash, "ISA", 3, TRUE);
 924     superisa = GvAVn(gv);
 925     GvMULTI_on(gv);
 926     sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
 927 #ifdef USE_ITHREADS
 928     av_push(superisa, newSVpvn_flags(CopSTASHPV(PL_curcop),
 929                                      strlen(CopSTASHPV(PL_curcop)),
 930                                      CopSTASH_flags(PL_curcop)
 931                                     ));
 932 #else
 933     av_push(superisa, newSVhek(CopSTASH(PL_curcop)
 934                                ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
 935 #endif
 936
 937     return stash;
 938 }
 939
 940 GV *
 941 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 942 {
 943     PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
 944
 945     return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
 946 }
 947
 948 GV *
 949 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
 950 {
 951     char *namepv;
 952     STRLEN namelen;
 953     PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
 954     namepv = SvPV(namesv, namelen);
 955     if (SvUTF8(namesv))
 956        flags |= SVf_UTF8;
 957     return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
 958 }
 959
 960 GV *
 961 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
 962 {
 963     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
 964     return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
 965 }
 966
 967 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
 968    even a U32 hash */
 969 GV *
 970 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
 971 {
 972     dVAR;
 973     register const char *nend;
 974     const char *nsplit = NULL;
 975     GV* gv;
 976     HV* ostash = stash;
 977     const char * const origname = name;
 978     SV *const error_report = MUTABLE_SV(stash);
 979     const U32 autoload = flags & GV_AUTOLOAD;
 980     const U32 do_croak = flags & GV_CROAK;
 981     const U32 is_utf8  = flags & SVf_UTF8;
 982
 983     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
 984
 985     if (SvTYPE(stash) < SVt_PVHV)
 986         stash = NULL;
 987     else {
 988         /* The only way stash can become NULL later on is if nsplit is set,
 989            which in turn means that there is no need for a SVt_PVHV case
 990            the error reporting code.  */
 991     }
 992
 993     for (nend = name; *nend || nend != (origname + len); nend++) {
 994         if (*nend == '\'') {
 995             nsplit = nend;
 996             name = nend + 1;
 997         }
 998         else if (*nend == ':' && *(nend + 1) == ':') {
 999             nsplit = nend++;
1000             name = nend + 1;
1001         }
1002     }
1003     if (nsplit) {
1004         if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
1005             /* ->SUPER::method should really be looked up in original stash */
1006             SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"::SUPER",
1007                       SVfARG(sv_2mortal(newSVhek(HvNAME_HEK((HV*)CopSTASH(PL_curcop)))))));
1008             /* __PACKAGE__::SUPER stash should be autovivified */
1009             stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr));
1010             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1011                          origname, HvNAME_get(stash), name) );
1012         }
1013         else {
1014             /* don't autovifify if ->NoSuchStash::method */
1015             stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
1016
1017             /* however, explicit calls to Pkg::SUPER::method may
1018                happen, and may require autovivification to work */
1019             if (!stash && (nsplit - origname) >= 7 &&
1020                 strnEQ(nsplit - 7, "::SUPER", 7) &&
1021                 gv_stashpvn(origname, nsplit - origname - 7, is_utf8))
1022               stash = gv_get_super_pkg(origname, nsplit - origname, flags);
1023         }
1024         ostash = stash;
1025     }
1026
1027     gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1028     if (!gv) {
1029         if (strEQ(name,"import") || strEQ(name,"unimport"))
1030             gv = MUTABLE_GV(&PL_sv_yes);
1031         else if (autoload)
1032             gv = gv_autoload_pvn(
1033                 ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
1034             );
1035         if (!gv && do_croak) {
1036             /* Right now this is exclusively for the benefit of S_method_common
1037                in pp_hot.c  */
1038             if (stash) {
1039                 /* If we can't find an IO::File method, it might be a call on
1040                  * a filehandle. If IO:File has not been loaded, try to
1041                  * require it first instead of croaking */
1042                 const char *stash_name = HvNAME_get(stash);
1043                 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1044                     && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1045                                        STR_WITH_LEN("IO/File.pm"), 0,
1046                                        HV_FETCH_ISEXISTS, NULL, 0)
1047                 ) {
1048                     require_pv("IO/File.pm");
1049                     gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1050                     if (gv)
1051                         return gv;
1052                 }
1053                 Perl_croak(aTHX_
1054                            "Can't locate object method \"%"SVf"\" via package \"%"SVf"\"",
1055                                     SVfARG(newSVpvn_flags(name, nend - name,
1056                                            SVs_TEMP | is_utf8)),
1057                                     SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))));
1058             }
1059             else {
1060                 SV* packnamesv;
1061
1062                 if (nsplit) {
1063                     packnamesv = newSVpvn_flags(origname, nsplit - origname,
1064                                                     SVs_TEMP | is_utf8);
1065                 } else {
1066                     packnamesv = sv_2mortal(newSVsv(error_report));
1067                 }
1068
1069                 Perl_croak(aTHX_
1070                            "Can't locate object method \"%"SVf"\" via package \"%"SVf"\""
1071                            " (perhaps you forgot to load \"%"SVf"\"?)",
1072                            SVfARG(newSVpvn_flags(name, nend - name,
1073                                 SVs_TEMP | is_utf8)),
1074                            SVfARG(packnamesv), SVfARG(packnamesv));
1075             }
1076         }
1077     }
1078     else if (autoload) {
1079         CV* const cv = GvCV(gv);
1080         if (!CvROOT(cv) && !CvXSUB(cv)) {
1081             GV* stubgv;
1082             GV* autogv;
1083
1084             if (CvANON(cv))
1085                 stubgv = gv;
1086             else {
1087                 stubgv = CvGV(cv);
1088                 if (GvCV(stubgv) != cv)         /* orphaned import */
1089                     stubgv = gv;
1090             }
1091             autogv = gv_autoload_pvn(GvSTASH(stubgv),
1092                                   GvNAME(stubgv), GvNAMELEN(stubgv),
1093                                   GV_AUTOLOAD_ISMETHOD
1094                                    | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1095             if (autogv)
1096                 gv = autogv;
1097         }
1098     }
1099
1100     return gv;
1101 }
1102
1103 GV*
1104 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1105 {
1106    char *namepv;
1107    STRLEN namelen;
1108    PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1109    namepv = SvPV(namesv, namelen);
1110    if (SvUTF8(namesv))
1111        flags |= SVf_UTF8;
1112    return gv_autoload_pvn(stash, namepv, namelen, flags);
1113 }
1114
1115 GV*
1116 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1117 {
1118    PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1119    return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1120 }
1121
1122 GV*
1123 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1124 {
1125     dVAR;
1126     GV* gv;
1127     CV* cv;
1128     HV* varstash;
1129     GV* vargv;
1130     SV* varsv;
1131     SV *packname = NULL;
1132     U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1133
1134     PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1135
1136     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1137         return NULL;
1138     if (stash) {
1139         if (SvTYPE(stash) < SVt_PVHV) {
1140             STRLEN packname_len = 0;
1141             const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1142             packname = newSVpvn_flags(packname_ptr, packname_len,
1143                                       SVs_TEMP | SvUTF8(stash));
1144             stash = NULL;
1145         }
1146         else
1147             packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1148     }
1149     if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8)))
1150         return NULL;
1151     cv = GvCV(gv);
1152
1153     if (!(CvROOT(cv) || CvXSUB(cv)))
1154         return NULL;
1155
1156     /*
1157      * Inheriting AUTOLOAD for non-methods works ... for now.
1158      */
1159     if (
1160         !(flags & GV_AUTOLOAD_ISMETHOD)
1161      && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1162     )
1163         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1164                          "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated",
1165                          SVfARG(packname),
1166                          SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
1167
1168     if (CvISXSUB(cv)) {
1169         /* rather than lookup/init $AUTOLOAD here
1170          * only to have the XSUB do another lookup for $AUTOLOAD
1171          * and split that value on the last '::',
1172          * pass along the same data via some unused fields in the CV
1173          */
1174         CvSTASH_set(cv, stash);
1175         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
1176         SvCUR_set(cv, len);
1177         if (is_utf8)
1178             SvUTF8_on(cv);
1179         return gv;
1180     }
1181
1182     /*
1183      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1184      * The subroutine's original name may not be "AUTOLOAD", so we don't
1185      * use that, but for lack of anything better we will use the sub's
1186      * original package to look up $AUTOLOAD.
1187      */
1188     varstash = GvSTASH(CvGV(cv));
1189     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1190     ENTER;
1191
1192     if (!isGV(vargv)) {
1193         gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1194 #ifdef PERL_DONT_CREATE_GVSV
1195         GvSV(vargv) = newSV(0);
1196 #endif
1197     }
1198     LEAVE;
1199     varsv = GvSVn(vargv);
1200     sv_setsv(varsv, packname);
1201     sv_catpvs(varsv, "::");
1202     /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1203        tainting if $FOO::AUTOLOAD was previously tainted, but is not now.  */
1204     sv_catpvn_mg(varsv, name, len);
1205     if (is_utf8)
1206         SvUTF8_on(varsv);
1207     return gv;
1208 }
1209
1210
1211 /* require_tie_mod() internal routine for requiring a module
1212  * that implements the logic of automatic ties like %! and %-
1213  *
1214  * The "gv" parameter should be the glob.
1215  * "varpv" holds the name of the var, used for error messages.
1216  * "namesv" holds the module name. Its refcount will be decremented.
1217  * "methpv" holds the method name to test for to check that things
1218  *   are working reasonably close to as expected.
1219  * "flags": if flag & 1 then save the scalar before loading.
1220  * For the protection of $! to work (it is set by this routine)
1221  * the sv slot must already be magicalized.
1222  */
1223 STATIC HV*
1224 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1225 {
1226     dVAR;
1227     HV* stash = gv_stashsv(namesv, 0);
1228
1229     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1230
1231     if (!stash || !(gv_fetchmethod(stash, methpv))) {
1232         SV *module = newSVsv(namesv);
1233         char varname = *varpv; /* varpv might be clobbered by load_module,
1234                                   so save it. For the moment it's always
1235                                   a single char. */
1236         dSP;
1237         ENTER;
1238         if ( flags & 1 )
1239             save_scalar(gv);
1240         PUSHSTACKi(PERLSI_MAGIC);
1241         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1242         POPSTACK;
1243         LEAVE;
1244         SPAGAIN;
1245         stash = gv_stashsv(namesv, 0);
1246         if (!stash)
1247             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
1248                     varname, SVfARG(namesv));
1249         else if (!gv_fetchmethod(stash, methpv))
1250             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
1251                     varname, SVfARG(namesv), methpv);
1252     }
1253     SvREFCNT_dec(namesv);
1254     return stash;
1255 }
1256
1257 /*
1258 =for apidoc gv_stashpv
1259
1260 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
1261 determine the length of C<name>, then calls C<gv_stashpvn()>.
1262
1263 =cut
1264 */
1265
1266 HV*
1267 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1268 {
1269     PERL_ARGS_ASSERT_GV_STASHPV;
1270     return gv_stashpvn(name, strlen(name), create);
1271 }
1272
1273 /*
1274 =for apidoc gv_stashpvn
1275
1276 Returns a pointer to the stash for a specified package.  The C<namelen>
1277 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
1278 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1279 created if it does not already exist.  If the package does not exist and
1280 C<flags> is 0 (or any other setting that does not create packages) then NULL
1281 is returned.
1282
1283
1284 =cut
1285 */
1286
1287 HV*
1288 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1289 {
1290     char smallbuf[128];
1291     char *tmpbuf;
1292     HV *stash;
1293     GV *tmpgv;
1294     U32 tmplen = namelen + 2;
1295
1296     PERL_ARGS_ASSERT_GV_STASHPVN;
1297
1298     if (tmplen <= sizeof smallbuf)
1299         tmpbuf = smallbuf;
1300     else
1301         Newx(tmpbuf, tmplen, char);
1302     Copy(name, tmpbuf, namelen, char);
1303     tmpbuf[namelen]   = ':';
1304     tmpbuf[namelen+1] = ':';
1305     tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1306     if (tmpbuf != smallbuf)
1307         Safefree(tmpbuf);
1308     if (!tmpgv)
1309         return NULL;
1310     stash = GvHV(tmpgv);
1311     if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1312     assert(stash);
1313     if (!HvNAME_get(stash)) {
1314         hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1315
1316         /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1317         /* If the containing stash has multiple effective
1318            names, see that this one gets them, too. */
1319         if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1320             mro_package_moved(stash, NULL, tmpgv, 1);
1321     }
1322     return stash;
1323 }
1324
1325 /*
1326 =for apidoc gv_stashsv
1327
1328 Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
1329
1330 =cut
1331 */
1332
1333 HV*
1334 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1335 {
1336     STRLEN len;
1337     const char * const ptr = SvPV_const(sv,len);
1338
1339     PERL_ARGS_ASSERT_GV_STASHSV;
1340
1341     return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
1342 }
1343
1344
1345 GV *
1346 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1347     PERL_ARGS_ASSERT_GV_FETCHPV;
1348     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1349 }
1350
1351 GV *
1352 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1353     STRLEN len;
1354     const char * const nambeg =
1355        SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1356     PERL_ARGS_ASSERT_GV_FETCHSV;
1357     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1358 }
1359
1360 STATIC void
1361 S_gv_magicalize_isa(pTHX_ GV *gv)
1362 {
1363     AV* av;
1364
1365     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1366
1367     av = GvAVn(gv);
1368     GvMULTI_on(gv);
1369     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1370              NULL, 0);
1371 }
1372
1373 STATIC void
1374 S_gv_magicalize_overload(pTHX_ GV *gv)
1375 {
1376     HV* hv;
1377
1378     PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
1379
1380     hv = GvHVn(gv);
1381     GvMULTI_on(gv);
1382     hv_magic(hv, NULL, PERL_MAGIC_overload);
1383 }
1384
1385 GV *
1386 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
1387                        const svtype sv_type)
1388 {
1389     dVAR;
1390     register const char *name = nambeg;
1391     register GV *gv = NULL;
1392     GV**gvp;
1393     I32 len;
1394     register const char *name_cursor;
1395     HV *stash = NULL;
1396     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
1397     const I32 no_expand = flags & GV_NOEXPAND;
1398     const I32 add = flags & ~GV_NOADD_MASK;
1399     const U32 is_utf8 = flags & SVf_UTF8;
1400     bool addmg = !!(flags & GV_ADDMG);
1401     const char *const name_end = nambeg + full_len;
1402     const char *const name_em1 = name_end - 1;
1403     U32 faking_it;
1404
1405     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1406
1407     if (flags & GV_NOTQUAL) {
1408         /* Caller promised that there is no stash, so we can skip the check. */
1409         len = full_len;
1410         goto no_stash;
1411     }
1412
1413     if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
1414         /* accidental stringify on a GV? */
1415         name++;
1416     }
1417
1418     for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1419         if (name_cursor < name_em1 &&
1420             ((*name_cursor == ':'
1421              && name_cursor[1] == ':')
1422             || *name_cursor == '\''))
1423         {
1424             if (!stash)
1425                 stash = PL_defstash;
1426             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1427                 return NULL;
1428
1429             len = name_cursor - name;
1430             if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1431                 const char *key;
1432                 if (*name_cursor == ':') {
1433                     key = name;
1434                     len += 2;
1435                 } else {
1436                     char *tmpbuf;
1437                     Newx(tmpbuf, len+2, char);
1438                     Copy(name, tmpbuf, len, char);
1439                     tmpbuf[len++] = ':';
1440                     tmpbuf[len++] = ':';
1441                     key = tmpbuf;
1442                 }
1443                 gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add);
1444                 gv = gvp ? *gvp : NULL;
1445                 if (gv && gv != (const GV *)&PL_sv_undef) {
1446                     if (SvTYPE(gv) != SVt_PVGV)
1447                         gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8);
1448                     else
1449                         GvMULTI_on(gv);
1450                 }
1451                 if (key != name)
1452                     Safefree(key);
1453                 if (!gv || gv == (const GV *)&PL_sv_undef)
1454                     return NULL;
1455
1456                 if (!(stash = GvHV(gv)))
1457                 {
1458                     stash = GvHV(gv) = newHV();
1459                     if (!HvNAME_get(stash)) {
1460                         if (GvSTASH(gv) == PL_defstash && len == 6
1461                          && strnEQ(name, "CORE", 4))
1462                             hv_name_set(stash, "CORE", 4, 0);
1463                         else
1464                             hv_name_set(
1465                                 stash, nambeg, name_cursor-nambeg, is_utf8
1466                             );
1467                         /* If the containing stash has multiple effective
1468                            names, see that this one gets them, too. */
1469                         if (HvAUX(GvSTASH(gv))->xhv_name_count)
1470                             mro_package_moved(stash, NULL, gv, 1);
1471                     }
1472                 }
1473                 else if (!HvNAME_get(stash))
1474                     hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8);
1475             }
1476
1477             if (*name_cursor == ':')
1478                 name_cursor++;
1479             name = name_cursor+1;
1480             if (name == name_end)
1481                 return gv
1482                     ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1483         }
1484     }
1485     len = name_cursor - name;
1486
1487     /* No stash in name, so see how we can default */
1488
1489     if (!stash) {
1490     no_stash:
1491         if (len && isIDFIRST_lazy(name)) {
1492             bool global = FALSE;
1493
1494             switch (len) {
1495             case 1:
1496                 if (*name == '_')
1497                     global = TRUE;
1498                 break;
1499             case 3:
1500                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1501                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1502                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1503                     global = TRUE;
1504                 break;
1505             case 4:
1506                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1507                     && name[3] == 'V')
1508                     global = TRUE;
1509                 break;
1510             case 5:
1511                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1512                     && name[3] == 'I' && name[4] == 'N')
1513                     global = TRUE;
1514                 break;
1515             case 6:
1516                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1517                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1518                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1519                     global = TRUE;
1520                 break;
1521             case 7:
1522                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1523                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1524                     && name[6] == 'T')
1525                     global = TRUE;
1526                 break;
1527             }
1528
1529             if (global)
1530                 stash = PL_defstash;
1531             else if (IN_PERL_COMPILETIME) {
1532                 stash = PL_curstash;
1533                 if (add && (PL_hints & HINT_STRICT_VARS) &&
1534                     sv_type != SVt_PVCV &&
1535                     sv_type != SVt_PVGV &&
1536                     sv_type != SVt_PVFM &&
1537                     sv_type != SVt_PVIO &&
1538                     !(len == 1 && sv_type == SVt_PV &&
1539                       (*name == 'a' || *name == 'b')) )
1540                 {
1541                     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0);
1542                     if (!gvp ||
1543                         *gvp == (const GV *)&PL_sv_undef ||
1544                         SvTYPE(*gvp) != SVt_PVGV)
1545                     {
1546                         stash = NULL;
1547                     }
1548                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1549                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1550                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1551                     {
1552                         SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8);
1553                         /* diag_listed_as: Variable "%s" is not imported%s */
1554                         Perl_ck_warner_d(
1555                             aTHX_ packWARN(WARN_MISC),
1556                             "Variable \"%c%"SVf"\" is not imported",
1557                             sv_type == SVt_PVAV ? '@' :
1558                             sv_type == SVt_PVHV ? '%' : '$',
1559                             SVfARG(namesv));
1560                         if (GvCVu(*gvp))
1561                             Perl_ck_warner_d(
1562                                 aTHX_ packWARN(WARN_MISC),
1563                                 "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv)
1564                             );
1565                         stash = NULL;
1566                     }
1567                 }
1568             }
1569             else
1570                 stash = CopSTASH(PL_curcop);
1571         }
1572         else
1573             stash = PL_defstash;
1574     }
1575
1576     /* By this point we should have a stash and a name */
1577
1578     if (!stash) {
1579         if (add) {
1580             SV * const err = Perl_mess(aTHX_
1581                  "Global symbol \"%s%"SVf"\" requires explicit package name",
1582                  (sv_type == SVt_PV ? "$"
1583                   : sv_type == SVt_PVAV ? "@"
1584                   : sv_type == SVt_PVHV ? "%"
1585                   : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
1586             GV *gv;
1587             if (USE_UTF8_IN_NAMES)
1588                 SvUTF8_on(err);
1589             qerror(err);
1590             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1591             if(!gv) {
1592                 /* symbol table under destruction */
1593                 return NULL;
1594             }
1595             stash = GvHV(gv);
1596         }
1597         else
1598             return NULL;
1599     }
1600
1601     if (!SvREFCNT(stash))       /* symbol table under destruction */
1602         return NULL;
1603
1604     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
1605     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1606         if (addmg) gv = (GV *)newSV(0);
1607         else return NULL;
1608     }
1609     else gv = *gvp, addmg = 0;
1610     /* From this point on, addmg means gv has not been inserted in the
1611        symtab yet. */
1612
1613     if (SvTYPE(gv) == SVt_PVGV) {
1614         if (add) {
1615             GvMULTI_on(gv);
1616             gv_init_svtype(gv, sv_type);
1617             if (len == 1 && stash == PL_defstash
1618                 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1619                 if (*name == '!')
1620                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1621                 else if (*name == '-' || *name == '+')
1622                     require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1623             }
1624             else if (len == 3 && sv_type == SVt_PVAV
1625                   && strnEQ(name, "ISA", 3)
1626                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1627                 gv_magicalize_isa(gv);
1628         }
1629         return gv;
1630     } else if (no_init) {
1631         assert(!addmg);
1632         return gv;
1633     } else if (no_expand && SvROK(gv)) {
1634         assert(!addmg);
1635         return gv;
1636     }
1637
1638     /* Adding a new symbol.
1639        Unless of course there was already something non-GV here, in which case
1640        we want to behave as if there was always a GV here, containing some sort
1641        of subroutine.
1642        Otherwise we run the risk of creating things like GvIO, which can cause
1643        subtle bugs. eg the one that tripped up SQL::Translator  */
1644
1645     faking_it = SvOK(gv);
1646
1647     if (add & GV_ADDWARN)
1648         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
1649                 SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
1650     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
1651
1652     if ( isIDFIRST_lazy_if(name, is_utf8)
1653                 && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
1654         GvMULTI_on(gv) ;
1655
1656     /* set up magic where warranted */
1657     if (stash != PL_defstash) { /* not the main stash */
1658         /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
1659            and VERSION. All the others apply only to the main stash or to
1660            CORE (which is checked right after this). */
1661         if (len > 2) {
1662             const char * const name2 = name + 1;
1663             switch (*name) {
1664             case 'E':
1665                 if (strnEQ(name2, "XPORT", 5))
1666                     GvMULTI_on(gv);
1667                 break;
1668             case 'I':
1669                 if (strEQ(name2, "SA"))
1670                     gv_magicalize_isa(gv);
1671                 break;
1672             case 'O':
1673                 if (strEQ(name2, "VERLOAD"))
1674                     gv_magicalize_overload(gv);
1675                 break;
1676             case 'V':
1677                 if (strEQ(name2, "ERSION"))
1678                     GvMULTI_on(gv);
1679                 break;
1680             default:
1681                 goto try_core;
1682             }
1683             goto add_magical_gv;
1684         }
1685       try_core:
1686         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1687           /* Avoid null warning: */
1688           const char * const stashname = HvNAME(stash); assert(stashname);
1689           if (strnEQ(stashname, "CORE", 4)
1690            && S_maybe_add_coresub(aTHX_
1691                 addmg ? stash : 0, gv, name, len, nambeg, full_len
1692               ))
1693             addmg = 0;
1694         }
1695     }
1696     else if (len > 1) {
1697 #ifndef EBCDIC
1698         if (*name > 'V' ) {
1699             NOOP;
1700             /* Nothing else to do.
1701                The compiler will probably turn the switch statement into a
1702                branch table. Make sure we avoid even that small overhead for
1703                the common case of lower case variable names.  */
1704         } else
1705 #endif
1706         {
1707             const char * const name2 = name + 1;
1708             switch (*name) {
1709             case 'A':
1710                 if (strEQ(name2, "RGV")) {
1711                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1712                 }
1713                 else if (strEQ(name2, "RGVOUT")) {
1714                     GvMULTI_on(gv);
1715                 }
1716                 break;
1717             case 'E':
1718                 if (strnEQ(name2, "XPORT", 5))
1719                     GvMULTI_on(gv);
1720                 break;
1721             case 'I':
1722                 if (strEQ(name2, "SA")) {
1723                     gv_magicalize_isa(gv);
1724                 }
1725                 break;
1726             case 'O':
1727                 if (strEQ(name2, "VERLOAD")) {
1728                     gv_magicalize_overload(gv);
1729                 }
1730                 break;
1731             case 'S':
1732                 if (strEQ(name2, "IG")) {
1733                     HV *hv;
1734                     I32 i;
1735                     if (!PL_psig_name) {
1736                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1737                         Newxz(PL_psig_pend, SIG_SIZE, int);
1738                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1739                     } else {
1740                         /* I think that the only way to get here is to re-use an
1741                            embedded perl interpreter, where the previous
1742                            use didn't clean up fully because
1743                            PL_perl_destruct_level was 0. I'm not sure that we
1744                            "support" that, in that I suspect in that scenario
1745                            there are sufficient other garbage values left in the
1746                            interpreter structure that something else will crash
1747                            before we get here. I suspect that this is one of
1748                            those "doctor, it hurts when I do this" bugs.  */
1749                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1750                         Zero(PL_psig_pend, SIG_SIZE, int);
1751                     }
1752                     GvMULTI_on(gv);
1753                     hv = GvHVn(gv);
1754                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1755                     for (i = 1; i < SIG_SIZE; i++) {
1756                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1757                         if (init)
1758                             sv_setsv(*init, &PL_sv_undef);
1759                     }
1760                 }
1761                 break;
1762             case 'V':
1763                 if (strEQ(name2, "ERSION"))
1764                     GvMULTI_on(gv);
1765                 break;
1766             case '\003':        /* $^CHILD_ERROR_NATIVE */
1767                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1768                     goto magicalize;
1769                 break;
1770             case '\005':        /* $^ENCODING */
1771                 if (strEQ(name2, "NCODING"))
1772                     goto magicalize;
1773                 break;
1774             case '\007':        /* $^GLOBAL_PHASE */
1775                 if (strEQ(name2, "LOBAL_PHASE"))
1776                     goto ro_magicalize;
1777                 break;
1778             case '\015':        /* $^MATCH */
1779                 if (strEQ(name2, "ATCH"))
1780                     goto magicalize;
1781             case '\017':        /* $^OPEN */
1782                 if (strEQ(name2, "PEN"))
1783                     goto magicalize;
1784                 break;
1785             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1786                 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1787                     goto magicalize;
1788                 break;
1789             case '\024':        /* ${^TAINT} */
1790                 if (strEQ(name2, "AINT"))
1791                     goto ro_magicalize;
1792                 break;
1793             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1794                 if (strEQ(name2, "NICODE"))
1795                     goto ro_magicalize;
1796                 if (strEQ(name2, "TF8LOCALE"))
1797                     goto ro_magicalize;
1798                 if (strEQ(name2, "TF8CACHE"))
1799                     goto magicalize;
1800                 break;
1801             case '\027':        /* $^WARNING_BITS */
1802                 if (strEQ(name2, "ARNING_BITS"))
1803                     goto magicalize;
1804                 break;
1805             case '1':
1806             case '2':
1807             case '3':
1808             case '4':
1809             case '5':
1810             case '6':
1811             case '7':
1812             case '8':
1813             case '9':
1814             {
1815                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1816                    this test  */
1817                 /* This snippet is taken from is_gv_magical */
1818                 const char *end = name + len;
1819                 while (--end > name) {
1820                     if (!isDIGIT(*end)) goto add_magical_gv;
1821                 }
1822                 goto magicalize;
1823             }
1824             }
1825         }
1826     } else {
1827         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1828            be case '\0' in this switch statement (ie a default case)  */
1829         switch (*name) {
1830         case '&':               /* $& */
1831         case '`':               /* $` */
1832         case '\'':              /* $' */
1833             if (
1834                 sv_type == SVt_PVAV ||
1835                 sv_type == SVt_PVHV ||
1836                 sv_type == SVt_PVCV ||
1837                 sv_type == SVt_PVFM ||
1838                 sv_type == SVt_PVIO
1839                 ) { break; }
1840             PL_sawampersand = TRUE;
1841             goto magicalize;
1842
1843         case ':':               /* $: */
1844             sv_setpv(GvSVn(gv),PL_chopset);
1845             goto magicalize;
1846
1847         case '?':               /* $? */
1848 #ifdef COMPLEX_STATUS
1849             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1850 #endif
1851             goto magicalize;
1852
1853         case '!':               /* $! */
1854             GvMULTI_on(gv);
1855             /* If %! has been used, automatically load Errno.pm. */
1856
1857             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1858
1859             /* magicalization must be done before require_tie_mod is called */
1860             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1861                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1862
1863             break;
1864         case '-':               /* $- */
1865         case '+':               /* $+ */
1866         GvMULTI_on(gv); /* no used once warnings here */
1867         {
1868             AV* const av = GvAVn(gv);
1869             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1870
1871             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1872             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1873             if (avc)
1874                 SvREADONLY_on(GvSVn(gv));
1875             SvREADONLY_on(av);
1876
1877             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1878                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1879
1880             break;
1881         }
1882         case '*':               /* $* */
1883         case '#':               /* $# */
1884             if (sv_type == SVt_PV)
1885                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1886                                  "$%c is no longer supported", *name);
1887             break;
1888         case '|':               /* $| */
1889             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1890             goto magicalize;
1891
1892         case '\010':    /* $^H */
1893             {
1894                 HV *const hv = GvHVn(gv);
1895                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1896             }
1897             goto magicalize;
1898         case '\023':    /* $^S */
1899         ro_magicalize:
1900             SvREADONLY_on(GvSVn(gv));
1901             /* FALL THROUGH */
1902         case '0':               /* $0 */
1903         case '1':               /* $1 */
1904         case '2':               /* $2 */
1905         case '3':               /* $3 */
1906         case '4':               /* $4 */
1907         case '5':               /* $5 */
1908         case '6':               /* $6 */
1909         case '7':               /* $7 */
1910         case '8':               /* $8 */
1911         case '9':               /* $9 */
1912         case '[':               /* $[ */
1913         case '^':               /* $^ */
1914         case '~':               /* $~ */
1915         case '=':               /* $= */
1916         case '%':               /* $% */
1917         case '.':               /* $. */
1918         case '(':               /* $( */
1919         case ')':               /* $) */
1920         case '<':               /* $< */
1921         case '>':               /* $> */
1922         case '\\':              /* $\ */
1923         case '/':               /* $/ */
1924         case '$':               /* $$ */
1925         case '\001':    /* $^A */
1926         case '\003':    /* $^C */
1927         case '\004':    /* $^D */
1928         case '\005':    /* $^E */
1929         case '\006':    /* $^F */
1930         case '\011':    /* $^I, NOT \t in EBCDIC */
1931         case '\016':    /* $^N */
1932         case '\017':    /* $^O */
1933         case '\020':    /* $^P */
1934         case '\024':    /* $^T */
1935         case '\027':    /* $^W */
1936         magicalize:
1937             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1938             break;
1939
1940         case '\014':    /* $^L */
1941             sv_setpvs(GvSVn(gv),"\f");
1942             PL_formfeed = GvSVn(gv);
1943             break;
1944         case ';':               /* $; */
1945             sv_setpvs(GvSVn(gv),"\034");
1946             break;
1947         case ']':               /* $] */
1948         {
1949             SV * const sv = GvSV(gv);
1950             if (!sv_derived_from(PL_patchlevel, "version"))
1951                 upg_version(PL_patchlevel, TRUE);
1952             GvSV(gv) = vnumify(PL_patchlevel);
1953             SvREADONLY_on(GvSV(gv));
1954             SvREFCNT_dec(sv);
1955         }
1956         break;
1957         case '\026':    /* $^V */
1958         {
1959             SV * const sv = GvSV(gv);
1960             GvSV(gv) = new_version(PL_patchlevel);
1961             SvREADONLY_on(GvSV(gv));
1962             SvREFCNT_dec(sv);
1963         }
1964         break;
1965         }
1966     }
1967   add_magical_gv:
1968     if (addmg) {
1969         if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
1970              GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
1971            ))
1972             (void)hv_store(stash,name,len,(SV *)gv,0);
1973         else SvREFCNT_dec(gv), gv = NULL;
1974     }
1975     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
1976     return gv;
1977 }
1978
1979 void
1980 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1981 {
1982     SV *name;
1983     const HV * const hv = GvSTASH(gv);
1984
1985     PERL_ARGS_ASSERT_GV_FULLNAME4;
1986
1987     if (!hv) {
1988         SvOK_off(sv);
1989         return;
1990     }
1991     sv_setpv(sv, prefix ? prefix : "");
1992
1993     name = HvNAME_get(hv)
1994             ? sv_2mortal(newSVhek(HvNAME_HEK(hv)))
1995             : newSVpvn_flags( "__ANON__", 8, SVs_TEMP );
1996
1997     if (keepmain || strnNE(SvPV_nolen(name), "main", SvCUR(name))) {
1998         sv_catsv(sv,name);
1999         sv_catpvs(sv,"::");
2000     }
2001     sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2002 }
2003
2004 void
2005 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2006 {
2007     const GV * const egv = GvEGVx(gv);
2008
2009     PERL_ARGS_ASSERT_GV_EFULLNAME4;
2010
2011     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2012 }
2013
2014 void
2015 Perl_gv_check(pTHX_ const HV *stash)
2016 {
2017     dVAR;
2018     register I32 i;
2019
2020     PERL_ARGS_ASSERT_GV_CHECK;
2021
2022     if (!HvARRAY(stash))
2023         return;
2024     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2025         const HE *entry;
2026         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2027             register GV *gv;
2028             HV *hv;
2029             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2030                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2031             {
2032                 if (hv != PL_defstash && hv != stash)
2033                      gv_check(hv);              /* nested package */
2034             }
2035             else if ( *HeKEY(entry) != '_'
2036                         && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2037                 const char *file;
2038                 gv = MUTABLE_GV(HeVAL(entry));
2039                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2040                     continue;
2041                 file = GvFILE(gv);
2042                 CopLINE_set(PL_curcop, GvLINE(gv));
2043 #ifdef USE_ITHREADS
2044                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
2045 #else
2046                 CopFILEGV(PL_curcop)
2047                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2048 #endif
2049                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2050                         "Name \"%"SVf"::%"SVf"\" used only once: possible typo",
2051                             SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))),
2052                             SVfARG(sv_2mortal(newSVhek(GvNAME_HEK(gv)))));
2053             }
2054         }
2055     }
2056 }
2057
2058 GV *
2059 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2060 {
2061     dVAR;
2062     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2063
2064     return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
2065                                     SVfARG(newSVpvn_flags(pack, strlen(pack),
2066                                             SVs_TEMP | flags)),
2067                                 (long)PL_gensym++),
2068                       GV_ADD, SVt_PVGV);
2069 }
2070
2071 /* hopefully this is only called on local symbol table entries */
2072
2073 GP*
2074 Perl_gp_ref(pTHX_ GP *gp)
2075 {
2076     dVAR;
2077     if (!gp)
2078         return NULL;
2079     gp->gp_refcnt++;
2080     if (gp->gp_cv) {
2081         if (gp->gp_cvgen) {
2082             /* If the GP they asked for a reference to contains
2083                a method cache entry, clear it first, so that we
2084                don't infect them with our cached entry */
2085             SvREFCNT_dec(gp->gp_cv);
2086             gp->gp_cv = NULL;
2087             gp->gp_cvgen = 0;
2088         }
2089     }
2090     return gp;
2091 }
2092
2093 void
2094 Perl_gp_free(pTHX_ GV *gv)
2095 {
2096     dVAR;
2097     GP* gp;
2098     int attempts = 100;
2099
2100     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2101         return;
2102     if (gp->gp_refcnt == 0) {
2103         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2104                          "Attempt to free unreferenced glob pointers"
2105                          pTHX__FORMAT pTHX__VALUE);
2106         return;
2107     }
2108     if (--gp->gp_refcnt > 0) {
2109         if (gp->gp_egv == gv)
2110             gp->gp_egv = 0;
2111         GvGP_set(gv, NULL);
2112         return;
2113     }
2114
2115     while (1) {
2116       /* Copy and null out all the glob slots, so destructors do not see
2117          freed SVs. */
2118       HEK * const file_hek = gp->gp_file_hek;
2119       SV  * const sv       = gp->gp_sv;
2120       AV  * const av       = gp->gp_av;
2121       HV  * const hv       = gp->gp_hv;
2122       IO  * const io       = gp->gp_io;
2123       CV  * const cv       = gp->gp_cv;
2124       CV  * const form     = gp->gp_form;
2125
2126       gp->gp_file_hek = NULL;
2127       gp->gp_sv       = NULL;
2128       gp->gp_av       = NULL;
2129       gp->gp_hv       = NULL;
2130       gp->gp_io       = NULL;
2131       gp->gp_cv       = NULL;
2132       gp->gp_form     = NULL;
2133
2134       if (file_hek)
2135         unshare_hek(file_hek);
2136
2137       SvREFCNT_dec(sv);
2138       SvREFCNT_dec(av);
2139       /* FIXME - another reference loop GV -> symtab -> GV ?
2140          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2141       if (hv && SvTYPE(hv) == SVt_PVHV) {
2142         const HEK *hvname_hek = HvNAME_HEK(hv);
2143         if (PL_stashcache && hvname_hek)
2144            (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2145                       (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2146                       G_DISCARD);
2147         SvREFCNT_dec(hv);
2148       }
2149       SvREFCNT_dec(io);
2150       SvREFCNT_dec(cv);
2151       SvREFCNT_dec(form);
2152
2153       if (!gp->gp_file_hek
2154        && !gp->gp_sv
2155        && !gp->gp_av
2156        && !gp->gp_hv
2157        && !gp->gp_io
2158        && !gp->gp_cv
2159        && !gp->gp_form) break;
2160
2161       if (--attempts == 0) {
2162         Perl_die(aTHX_
2163           "panic: gp_free failed to free glob pointer - "
2164           "something is repeatedly re-creating entries"
2165         );
2166       }
2167     }
2168
2169     Safefree(gp);
2170     GvGP_set(gv, NULL);
2171 }
2172
2173 int
2174 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2175 {
2176     AMT * const amtp = (AMT*)mg->mg_ptr;
2177     PERL_UNUSED_ARG(sv);
2178
2179     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2180
2181     if (amtp && AMT_AMAGIC(amtp)) {
2182         int i;
2183         for (i = 1; i < NofAMmeth; i++) {
2184             CV * const cv = amtp->table[i];
2185             if (cv) {
2186                 SvREFCNT_dec(MUTABLE_SV(cv));
2187                 amtp->table[i] = NULL;
2188             }
2189         }
2190     }
2191  return 0;
2192 }
2193
2194 /* Updates and caches the CV's */
2195 /* Returns:
2196  * 1 on success and there is some overload
2197  * 0 if there is no overload
2198  * -1 if some error occurred and it couldn't croak
2199  */
2200
2201 int
2202 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2203 {
2204   dVAR;
2205   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2206   AMT amt;
2207   const struct mro_meta* stash_meta = HvMROMETA(stash);
2208   U32 newgen;
2209
2210   PERL_ARGS_ASSERT_GV_AMUPDATE;
2211
2212   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2213   if (mg) {
2214       const AMT * const amtp = (AMT*)mg->mg_ptr;
2215       if (amtp->was_ok_am == PL_amagic_generation
2216           && amtp->was_ok_sub == newgen) {
2217           return AMT_OVERLOADED(amtp) ? 1 : 0;
2218       }
2219       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2220   }
2221
2222   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2223
2224   Zero(&amt,1,AMT);
2225   amt.was_ok_am = PL_amagic_generation;
2226   amt.was_ok_sub = newgen;
2227   amt.fallback = AMGfallNO;
2228   amt.flags = 0;
2229
2230   {
2231     int filled = 0, have_ovl = 0;
2232     int i, lim = 1;
2233
2234     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2235
2236     /* Try to find via inheritance. */
2237     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2238     SV * const sv = gv ? GvSV(gv) : NULL;
2239     CV* cv;
2240
2241     if (!gv)
2242         lim = DESTROY_amg;              /* Skip overloading entries. */
2243 #ifdef PERL_DONT_CREATE_GVSV
2244     else if (!sv) {
2245         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2246     }
2247 #endif
2248     else if (SvTRUE(sv))
2249         amt.fallback=AMGfallYES;
2250     else if (SvOK(sv))
2251         amt.fallback=AMGfallNEVER;
2252
2253     for (i = 1; i < lim; i++)
2254         amt.table[i] = NULL;
2255     for (; i < NofAMmeth; i++) {
2256         const char * const cooky = PL_AMG_names[i];
2257         /* Human-readable form, for debugging: */
2258         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2259         const STRLEN l = PL_AMG_namelens[i];
2260
2261         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2262                      cp, HvNAME_get(stash)) );
2263         /* don't fill the cache while looking up!
2264            Creation of inheritance stubs in intermediate packages may
2265            conflict with the logic of runtime method substitution.
2266            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2267            then we could have created stubs for "(+0" in A and C too.
2268            But if B overloads "bool", we may want to use it for
2269            numifying instead of C's "+0". */
2270         if (i >= DESTROY_amg)
2271             gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
2272         else                            /* Autoload taken care of below */
2273             gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2274         cv = 0;
2275         if (gv && (cv = GvCV(gv))) {
2276             if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2277               const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2278               if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2279                && strEQ(hvname, "overload")) {
2280                 /* This is a hack to support autoloading..., while
2281                    knowing *which* methods were declared as overloaded. */
2282                 /* GvSV contains the name of the method. */
2283                 GV *ngv = NULL;
2284                 SV *gvsv = GvSV(gv);
2285
2286                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2287                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2288                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2289                 if (!gvsv || !SvPOK(gvsv)
2290                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2291                 {
2292                     /* Can be an import stub (created by "can"). */
2293                     if (destructing) {
2294                         return -1;
2295                     }
2296                     else {
2297                         const SV * const name = (gvsv && SvPOK(gvsv))
2298                                                     ? gvsv
2299                                                     : newSVpvs_flags("???", SVs_TEMP);
2300                         Perl_croak(aTHX_ "%s method \"%"SVf256
2301                                     "\" overloading \"%s\" "\
2302                                     "in package \"%"SVf256"\"",
2303                                    (GvCVGEN(gv) ? "Stub found while resolving"
2304                                     : "Can't resolve"),
2305                                    SVfARG(name), cp,
2306                                    SVfARG(sv_2mortal(newSVhek(
2307                                         HvNAME_HEK(stash)
2308                                    ))));
2309                     }
2310                 }
2311                 cv = GvCV(gv = ngv);
2312               }
2313             }
2314             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2315                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2316                          GvNAME(CvGV(cv))) );
2317             filled = 1;
2318             if (i < DESTROY_amg)
2319                 have_ovl = 1;
2320         } else if (gv) {                /* Autoloaded... */
2321             cv = MUTABLE_CV(gv);
2322             filled = 1;
2323         }
2324         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2325     }
2326     if (filled) {
2327       AMT_AMAGIC_on(&amt);
2328       if (have_ovl)
2329           AMT_OVERLOADED_on(&amt);
2330       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2331                                                 (char*)&amt, sizeof(AMT));
2332       return have_ovl;
2333     }
2334   }
2335   /* Here we have no table: */
2336   /* no_table: */
2337   AMT_AMAGIC_off(&amt);
2338   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2339                                                 (char*)&amt, sizeof(AMTS));
2340   return 0;
2341 }
2342
2343
2344 CV*
2345 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2346 {
2347     dVAR;
2348     MAGIC *mg;
2349     AMT *amtp;
2350     U32 newgen;
2351     struct mro_meta* stash_meta;
2352
2353     if (!stash || !HvNAME_get(stash))
2354         return NULL;
2355
2356     stash_meta = HvMROMETA(stash);
2357     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2358
2359     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2360     if (!mg) {
2361       do_update:
2362         /* If we're looking up a destructor to invoke, we must avoid
2363          * that Gv_AMupdate croaks, because we might be dying already */
2364         if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2365             /* and if it didn't found a destructor, we fall back
2366              * to a simpler method that will only look for the
2367              * destructor instead of the whole magic */
2368             if (id == DESTROY_amg) {
2369                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2370                 if (gv)
2371                     return GvCV(gv);
2372             }
2373             return NULL;
2374         }
2375         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2376     }
2377     assert(mg);
2378     amtp = (AMT*)mg->mg_ptr;
2379     if ( amtp->was_ok_am != PL_amagic_generation
2380          || amtp->was_ok_sub != newgen )
2381         goto do_update;
2382     if (AMT_AMAGIC(amtp)) {
2383         CV * const ret = amtp->table[id];
2384         if (ret && isGV(ret)) {         /* Autoloading stab */
2385             /* Passing it through may have resulted in a warning
2386                "Inherited AUTOLOAD for a non-method deprecated", since
2387                our caller is going through a function call, not a method call.
2388                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2389             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2390
2391             if (gv && GvCV(gv))
2392                 return GvCV(gv);
2393         }
2394         return ret;
2395     }
2396
2397     return NULL;
2398 }
2399
2400
2401 /* Implement tryAMAGICun_MG macro.
2402    Do get magic, then see if the stack arg is overloaded and if so call it.
2403    Flags:
2404         AMGf_set     return the arg using SETs rather than assigning to
2405                      the targ
2406         AMGf_numeric apply sv_2num to the stack arg.
2407 */
2408
2409 bool
2410 Perl_try_amagic_un(pTHX_ int method, int flags) {
2411     dVAR;
2412     dSP;
2413     SV* tmpsv;
2414     SV* const arg = TOPs;
2415
2416     SvGETMAGIC(arg);
2417
2418     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2419                                               AMGf_noright | AMGf_unary))) {
2420         if (flags & AMGf_set) {
2421             SETs(tmpsv);
2422         }
2423         else {
2424             dTARGET;
2425             if (SvPADMY(TARG)) {
2426                 sv_setsv(TARG, tmpsv);
2427                 SETTARG;
2428             }
2429             else
2430                 SETs(tmpsv);
2431         }
2432         PUTBACK;
2433         return TRUE;
2434     }
2435
2436     if ((flags & AMGf_numeric) && SvROK(arg))
2437         *sp = sv_2num(arg);
2438     return FALSE;
2439 }
2440
2441
2442 /* Implement tryAMAGICbin_MG macro.
2443    Do get magic, then see if the two stack args are overloaded and if so
2444    call it.
2445    Flags:
2446         AMGf_set     return the arg using SETs rather than assigning to
2447                      the targ
2448         AMGf_assign  op may be called as mutator (eg +=)
2449         AMGf_numeric apply sv_2num to the stack arg.
2450 */
2451
2452 bool
2453 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2454     dVAR;
2455     dSP;
2456     SV* const left = TOPm1s;
2457     SV* const right = TOPs;
2458
2459     SvGETMAGIC(left);
2460     if (left != right)
2461         SvGETMAGIC(right);
2462
2463     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2464         SV * const tmpsv = amagic_call(left, right, method,
2465                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2466         if (tmpsv) {
2467             if (flags & AMGf_set) {
2468                 (void)POPs;
2469                 SETs(tmpsv);
2470             }
2471             else {
2472                 dATARGET;
2473                 (void)POPs;
2474                 if (opASSIGN || SvPADMY(TARG)) {
2475                     sv_setsv(TARG, tmpsv);
2476                     SETTARG;
2477                 }
2478                 else
2479                     SETs(tmpsv);
2480             }
2481             PUTBACK;
2482             return TRUE;
2483         }
2484     }
2485     if(left==right && SvGMAGICAL(left)) {
2486         SV * const left = sv_newmortal();
2487         *(sp-1) = left;
2488         /* Print the uninitialized warning now, so it includes the vari-
2489            able name. */
2490         if (!SvOK(right)) {
2491             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2492             sv_setsv_flags(left, &PL_sv_no, 0);
2493         }
2494         else sv_setsv_flags(left, right, 0);
2495         SvGETMAGIC(right);
2496     }
2497     if (flags & AMGf_numeric) {
2498         if (SvROK(TOPm1s))
2499             *(sp-1) = sv_2num(TOPm1s);
2500         if (SvROK(right))
2501             *sp     = sv_2num(right);
2502     }
2503     return FALSE;
2504 }
2505
2506 SV *
2507 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2508     SV *tmpsv = NULL;
2509
2510     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2511
2512     while (SvAMAGIC(ref) &&
2513            (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2514                                 AMGf_noright | AMGf_unary))) {
2515         if (!SvROK(tmpsv))
2516             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2517         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2518             /* Bail out if it returns us the same reference.  */
2519             return tmpsv;
2520         }
2521         ref = tmpsv;
2522     }
2523     return tmpsv ? tmpsv : ref;
2524 }
2525
2526 SV*
2527 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2528 {
2529   dVAR;
2530   MAGIC *mg;
2531   CV *cv=NULL;
2532   CV **cvp=NULL, **ocvp=NULL;
2533   AMT *amtp=NULL, *oamtp=NULL;
2534   int off = 0, off1, lr = 0, notfound = 0;
2535   int postpr = 0, force_cpy = 0;
2536   int assign = AMGf_assign & flags;
2537   const int assignshift = assign ? 1 : 0;
2538   int use_default_op = 0;
2539 #ifdef DEBUGGING
2540   int fl=0;
2541 #endif
2542   HV* stash=NULL;
2543
2544   PERL_ARGS_ASSERT_AMAGIC_CALL;
2545
2546   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2547       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2548
2549       if ( !lex_mask || !SvOK(lex_mask) )
2550           /* overloading lexically disabled */
2551           return NULL;
2552       else if ( lex_mask && SvPOK(lex_mask) ) {
2553           /* we have an entry in the hints hash, check if method has been
2554            * masked by overloading.pm */
2555           STRLEN len;
2556           const int offset = method / 8;
2557           const int bit    = method % 8;
2558           char *pv = SvPV(lex_mask, len);
2559
2560           /* Bit set, so this overloading operator is disabled */
2561           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2562               return NULL;
2563       }
2564   }
2565
2566   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2567       && (stash = SvSTASH(SvRV(left)))
2568       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2569       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2570                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2571                         : NULL))
2572       && ((cv = cvp[off=method+assignshift])
2573           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2574                                                           * usual method */
2575                   (
2576 #ifdef DEBUGGING
2577                    fl = 1,
2578 #endif
2579                    cv = cvp[off=method])))) {
2580     lr = -1;                    /* Call method for left argument */
2581   } else {
2582     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2583       int logic;
2584
2585       /* look for substituted methods */
2586       /* In all the covered cases we should be called with assign==0. */
2587          switch (method) {
2588          case inc_amg:
2589            force_cpy = 1;
2590            if ((cv = cvp[off=add_ass_amg])
2591                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2592              right = &PL_sv_yes; lr = -1; assign = 1;
2593            }
2594            break;
2595          case dec_amg:
2596            force_cpy = 1;
2597            if ((cv = cvp[off = subtr_ass_amg])
2598                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2599              right = &PL_sv_yes; lr = -1; assign = 1;
2600            }
2601            break;
2602          case bool__amg:
2603            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2604            break;
2605          case numer_amg:
2606            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2607            break;
2608          case string_amg:
2609            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2610            break;
2611          case not_amg:
2612            (void)((cv = cvp[off=bool__amg])
2613                   || (cv = cvp[off=numer_amg])
2614                   || (cv = cvp[off=string_amg]));
2615            if (cv)
2616                postpr = 1;
2617            break;
2618          case copy_amg:
2619            {
2620              /*
2621                   * SV* ref causes confusion with the interpreter variable of
2622                   * the same name
2623                   */
2624              SV* const tmpRef=SvRV(left);
2625              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2626                 /*
2627                  * Just to be extra cautious.  Maybe in some
2628                  * additional cases sv_setsv is safe, too.
2629                  */
2630                 SV* const newref = newSVsv(tmpRef);
2631                 SvOBJECT_on(newref);
2632                 /* As a bit of a source compatibility hack, SvAMAGIC() and
2633                    friends dereference an RV, to behave the same was as when
2634                    overloading was stored on the reference, not the referant.
2635                    Hence we can't use SvAMAGIC_on()
2636                 */
2637                 SvFLAGS(newref) |= SVf_AMAGIC;
2638                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2639                 return newref;
2640              }
2641            }
2642            break;
2643          case abs_amg:
2644            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2645                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2646              SV* const nullsv=sv_2mortal(newSViv(0));
2647              if (off1==lt_amg) {
2648                SV* const lessp = amagic_call(left,nullsv,
2649                                        lt_amg,AMGf_noright);
2650                logic = SvTRUE(lessp);
2651              } else {
2652                SV* const lessp = amagic_call(left,nullsv,
2653                                        ncmp_amg,AMGf_noright);
2654                logic = (SvNV(lessp) < 0);
2655              }
2656              if (logic) {
2657                if (off==subtr_amg) {
2658                  right = left;
2659                  left = nullsv;
2660                  lr = 1;
2661                }
2662              } else {
2663                return left;
2664              }
2665            }
2666            break;
2667          case neg_amg:
2668            if ((cv = cvp[off=subtr_amg])) {
2669              right = left;
2670              left = sv_2mortal(newSViv(0));
2671              lr = 1;
2672            }
2673            break;
2674          case int_amg:
2675          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2676          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2677          case regexp_amg:
2678              /* FAIL safe */
2679              return NULL;       /* Delegate operation to standard mechanisms. */
2680              break;
2681          case to_sv_amg:
2682          case to_av_amg:
2683          case to_hv_amg:
2684          case to_gv_amg:
2685          case to_cv_amg:
2686              /* FAIL safe */
2687              return left;       /* Delegate operation to standard mechanisms. */
2688              break;
2689          default:
2690            goto not_found;
2691          }
2692          if (!cv) goto not_found;
2693     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2694                && (stash = SvSTASH(SvRV(right)))
2695                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2696                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2697                           ? (amtp = (AMT*)mg->mg_ptr)->table
2698                           : NULL))
2699                && (cv = cvp[off=method])) { /* Method for right
2700                                              * argument found */
2701       lr=1;
2702     } else if (((cvp && amtp->fallback > AMGfallNEVER)
2703                 || (ocvp && oamtp->fallback > AMGfallNEVER))
2704                && !(flags & AMGf_unary)) {
2705                                 /* We look for substitution for
2706                                  * comparison operations and
2707                                  * concatenation */
2708       if (method==concat_amg || method==concat_ass_amg
2709           || method==repeat_amg || method==repeat_ass_amg) {
2710         return NULL;            /* Delegate operation to string conversion */
2711       }
2712       off = -1;
2713       switch (method) {
2714          case lt_amg:
2715          case le_amg:
2716          case gt_amg:
2717          case ge_amg:
2718          case eq_amg:
2719          case ne_amg:
2720              off = ncmp_amg;
2721              break;
2722          case slt_amg:
2723          case sle_amg:
2724          case sgt_amg:
2725          case sge_amg:
2726          case seq_amg:
2727          case sne_amg:
2728              off = scmp_amg;
2729              break;
2730          }
2731       if (off != -1) {
2732           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2733               cv = ocvp[off];
2734               lr = -1;
2735           }
2736           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2737               cv = cvp[off];
2738               lr = 1;
2739           }
2740       }
2741       if (cv)
2742           postpr = 1;
2743       else
2744           goto not_found;
2745     } else {
2746     not_found:                  /* No method found, either report or croak */
2747       switch (method) {
2748          case to_sv_amg:
2749          case to_av_amg:
2750          case to_hv_amg:
2751          case to_gv_amg:
2752          case to_cv_amg:
2753              /* FAIL safe */
2754              return left;       /* Delegate operation to standard mechanisms. */
2755              break;
2756       }
2757       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2758         notfound = 1; lr = -1;
2759       } else if (cvp && (cv=cvp[nomethod_amg])) {
2760         notfound = 1; lr = 1;
2761       } else if ((use_default_op =
2762                   (!ocvp || oamtp->fallback >= AMGfallYES)
2763                   && (!cvp || amtp->fallback >= AMGfallYES))
2764                  && !DEBUG_o_TEST) {
2765         /* Skip generating the "no method found" message.  */
2766         return NULL;
2767       } else {
2768         SV *msg;
2769         if (off==-1) off=method;
2770         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2771                       "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2772                       AMG_id2name(method + assignshift),
2773                       (flags & AMGf_unary ? " " : "\n\tleft "),
2774                       SvAMAGIC(left)?
2775                         "in overloaded package ":
2776                         "has no overloaded magic",
2777                       SvAMAGIC(left)?
2778                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2779                         SVfARG(&PL_sv_no),
2780                       SvAMAGIC(right)?
2781                         ",\n\tright argument in overloaded package ":
2782                         (flags & AMGf_unary
2783                          ? ""
2784                          : ",\n\tright argument has no overloaded magic"),
2785                       SvAMAGIC(right)?
2786                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2787                         SVfARG(&PL_sv_no)));
2788         if (use_default_op) {
2789           DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
2790         } else {
2791           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2792         }
2793         return NULL;
2794       }
2795       force_cpy = force_cpy || assign;
2796     }
2797   }
2798 #ifdef DEBUGGING
2799   if (!notfound) {
2800     DEBUG_o(Perl_deb(aTHX_
2801                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
2802                      AMG_id2name(off),
2803                      method+assignshift==off? "" :
2804                      " (initially \"",
2805                      method+assignshift==off? "" :
2806                      AMG_id2name(method+assignshift),
2807                      method+assignshift==off? "" : "\")",
2808                      flags & AMGf_unary? "" :
2809                      lr==1 ? " for right argument": " for left argument",
2810                      flags & AMGf_unary? " for argument" : "",
2811                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
2812                      fl? ",\n\tassignment variant used": "") );
2813   }
2814 #endif
2815     /* Since we use shallow copy during assignment, we need
2816      * to dublicate the contents, probably calling user-supplied
2817      * version of copy operator
2818      */
2819     /* We need to copy in following cases:
2820      * a) Assignment form was called.
2821      *          assignshift==1,  assign==T, method + 1 == off
2822      * b) Increment or decrement, called directly.
2823      *          assignshift==0,  assign==0, method + 0 == off
2824      * c) Increment or decrement, translated to assignment add/subtr.
2825      *          assignshift==0,  assign==T,
2826      *          force_cpy == T
2827      * d) Increment or decrement, translated to nomethod.
2828      *          assignshift==0,  assign==0,
2829      *          force_cpy == T
2830      * e) Assignment form translated to nomethod.
2831      *          assignshift==1,  assign==T, method + 1 != off
2832      *          force_cpy == T
2833      */
2834     /*  off is method, method+assignshift, or a result of opcode substitution.
2835      *  In the latter case assignshift==0, so only notfound case is important.
2836      */
2837   if (( (method + assignshift == off)
2838         && (assign || (method == inc_amg) || (method == dec_amg)))
2839       || force_cpy)
2840   {
2841       /* newSVsv does not behave as advertised, so we copy missing
2842        * information by hand */
2843       SV *tmpRef = SvRV(left);
2844       SV *rv_copy;
2845       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2846           SvRV_set(left, rv_copy);
2847           SvSETMAGIC(left);
2848           SvREFCNT_dec(tmpRef);
2849       }
2850   }
2851
2852   {
2853     dSP;
2854     BINOP myop;
2855     SV* res;
2856     const bool oldcatch = CATCH_GET;
2857
2858     CATCH_SET(TRUE);
2859     Zero(&myop, 1, BINOP);
2860     myop.op_last = (OP *) &myop;
2861     myop.op_next = NULL;
2862     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2863
2864     PUSHSTACKi(PERLSI_OVERLOAD);
2865     ENTER;
2866     SAVEOP();
2867     PL_op = (OP *) &myop;
2868     if (PERLDB_SUB && PL_curstash != PL_debstash)
2869         PL_op->op_private |= OPpENTERSUB_DB;
2870     PUTBACK;
2871     Perl_pp_pushmark(aTHX);
2872
2873     EXTEND(SP, notfound + 5);
2874     PUSHs(lr>0? right: left);
2875     PUSHs(lr>0? left: right);
2876     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2877     if (notfound) {
2878       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2879                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2880     }
2881     PUSHs(MUTABLE_SV(cv));
2882     PUTBACK;
2883
2884     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2885       CALLRUNOPS(aTHX);
2886     LEAVE;
2887     SPAGAIN;
2888
2889     res=POPs;
2890     PUTBACK;
2891     POPSTACK;
2892     CATCH_SET(oldcatch);
2893
2894     if (postpr) {
2895       int ans;
2896       switch (method) {
2897       case le_amg:
2898       case sle_amg:
2899         ans=SvIV(res)<=0; break;
2900       case lt_amg:
2901       case slt_amg:
2902         ans=SvIV(res)<0; break;
2903       case ge_amg:
2904       case sge_amg:
2905         ans=SvIV(res)>=0; break;
2906       case gt_amg:
2907       case sgt_amg:
2908         ans=SvIV(res)>0; break;
2909       case eq_amg:
2910       case seq_amg:
2911         ans=SvIV(res)==0; break;
2912       case ne_amg:
2913       case sne_amg:
2914         ans=SvIV(res)!=0; break;
2915       case inc_amg:
2916       case dec_amg:
2917         SvSetSV(left,res); return left;
2918       case not_amg:
2919         ans=!SvTRUE(res); break;
2920       default:
2921         ans=0; break;
2922       }
2923       return boolSV(ans);
2924     } else if (method==copy_amg) {
2925       if (!SvROK(res)) {
2926         Perl_croak(aTHX_ "Copy method did not return a reference");
2927       }
2928       return SvREFCNT_inc(SvRV(res));
2929     } else {
2930       return res;
2931     }
2932   }
2933 }
2934
2935 void
2936 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2937 {
2938     dVAR;
2939     U32 hash;
2940
2941     PERL_ARGS_ASSERT_GV_NAME_SET;
2942
2943     if (len > I32_MAX)
2944         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2945
2946     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2947         unshare_hek(GvNAME_HEK(gv));
2948     }
2949
2950     PERL_HASH(hash, name, len);
2951     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2952 }
2953
2954 /*
2955 =for apidoc gv_try_downgrade
2956
2957 If the typeglob C<gv> can be expressed more succinctly, by having
2958 something other than a real GV in its place in the stash, replace it
2959 with the optimised form.  Basic requirements for this are that C<gv>
2960 is a real typeglob, is sufficiently ordinary, and is only referenced
2961 from its package.  This function is meant to be used when a GV has been
2962 looked up in part to see what was there, causing upgrading, but based
2963 on what was found it turns out that the real GV isn't required after all.
2964
2965 If C<gv> is a completely empty typeglob, it is deleted from the stash.
2966
2967 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2968 sub, the typeglob is replaced with a scalar-reference placeholder that
2969 more compactly represents the same thing.
2970
2971 =cut
2972 */
2973
2974 void
2975 Perl_gv_try_downgrade(pTHX_ GV *gv)
2976 {
2977     HV *stash;
2978     CV *cv;
2979     HEK *namehek;
2980     SV **gvp;
2981     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
2982
2983     /* XXX Why and where does this leave dangling pointers during global
2984        destruction? */
2985     if (PL_phase == PERL_PHASE_DESTRUCT) return;
2986
2987     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
2988             !SvOBJECT(gv) && !SvREADONLY(gv) &&
2989             isGV_with_GP(gv) && GvGP(gv) &&
2990             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
2991             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
2992             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2993         return;
2994     if (SvMAGICAL(gv)) {
2995         MAGIC *mg;
2996         /* only backref magic is allowed */
2997         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
2998             return;
2999         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3000             if (mg->mg_type != PERL_MAGIC_backref)
3001                 return;
3002         }
3003     }
3004     cv = GvCV(gv);
3005     if (!cv) {
3006         HEK *gvnhek = GvNAME_HEK(gv);
3007         (void)hv_delete(stash, HEK_KEY(gvnhek),
3008             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3009     } else if (GvMULTI(gv) && cv &&
3010             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3011             CvSTASH(cv) == stash && CvGV(cv) == gv &&
3012             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3013             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3014             (namehek = GvNAME_HEK(gv)) &&
3015             (gvp = hv_fetch(stash, HEK_KEY(namehek),
3016                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3017             *gvp == (SV*)gv) {
3018         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3019         SvREFCNT(gv) = 0;
3020         sv_clear((SV*)gv);
3021         SvREFCNT(gv) = 1;
3022         SvFLAGS(gv) = SVt_IV|SVf_ROK;
3023         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3024                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3025         SvRV_set(gv, value);
3026     }
3027 }
3028
3029 #include "XSUB.h"
3030
3031 static void
3032 core_xsub(pTHX_ CV* cv)
3033 {
3034     Perl_croak(aTHX_
3035        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3036     );
3037 }
3038
3039 /*
3040  * Local variables:
3041  * c-indentation-style: bsd
3042  * c-basic-offset: 4
3043  * indent-tabs-mode: t
3044  * End:
3045  *
3046  * ex: set ts=8 sts=4 sw=4 noet:
3047  */