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 = NULL;
 451     int opnum = 0;
 452     SV *opnumsv;
 453     bool ampable = TRUE; /* &{}-able */
 454     COP *oldcurcop = NULL;
 455     yy_parser *oldparser = NULL;
 456     I32 oldsavestack_ix = 0;
 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 @%"HEKf"::ISA",
 722                            SVfARG(linear_sv),
 723                            HEKfARG(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_
1007                      "%"HEKf"::SUPER",
1008                       HEKfARG(HvNAME_HEK((HV*)CopSTASH(PL_curcop)))
1009             ));
1010             /* __PACKAGE__::SUPER stash should be autovivified */
1011             stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr));
1012             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1013                          origname, HvNAME_get(stash), name) );
1014         }
1015         else {
1016             /* don't autovifify if ->NoSuchStash::method */
1017             stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
1018
1019             /* however, explicit calls to Pkg::SUPER::method may
1020                happen, and may require autovivification to work */
1021             if (!stash && (nsplit - origname) >= 7 &&
1022                 strnEQ(nsplit - 7, "::SUPER", 7) &&
1023                 gv_stashpvn(origname, nsplit - origname - 7, is_utf8))
1024               stash = gv_get_super_pkg(origname, nsplit - origname, flags);
1025         }
1026         ostash = stash;
1027     }
1028
1029     gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1030     if (!gv) {
1031         if (strEQ(name,"import") || strEQ(name,"unimport"))
1032             gv = MUTABLE_GV(&PL_sv_yes);
1033         else if (autoload)
1034             gv = gv_autoload_pvn(
1035                 ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
1036             );
1037         if (!gv && do_croak) {
1038             /* Right now this is exclusively for the benefit of S_method_common
1039                in pp_hot.c  */
1040             if (stash) {
1041                 /* If we can't find an IO::File method, it might be a call on
1042                  * a filehandle. If IO:File has not been loaded, try to
1043                  * require it first instead of croaking */
1044                 const char *stash_name = HvNAME_get(stash);
1045                 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1046                     && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1047                                        STR_WITH_LEN("IO/File.pm"), 0,
1048                                        HV_FETCH_ISEXISTS, NULL, 0)
1049                 ) {
1050                     require_pv("IO/File.pm");
1051                     gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1052                     if (gv)
1053                         return gv;
1054                 }
1055                 Perl_croak(aTHX_
1056                            "Can't locate object method \"%"SVf
1057                            "\" via package \"%"HEKf"\"",
1058                                     SVfARG(newSVpvn_flags(name, nend - name,
1059                                            SVs_TEMP | is_utf8)),
1060                                     HEKfARG(HvNAME_HEK(stash)));
1061             }
1062             else {
1063                 SV* packnamesv;
1064
1065                 if (nsplit) {
1066                     packnamesv = newSVpvn_flags(origname, nsplit - origname,
1067                                                     SVs_TEMP | is_utf8);
1068                 } else {
1069                     packnamesv = sv_2mortal(newSVsv(error_report));
1070                 }
1071
1072                 Perl_croak(aTHX_
1073                            "Can't locate object method \"%"SVf"\" via package \"%"SVf"\""
1074                            " (perhaps you forgot to load \"%"SVf"\"?)",
1075                            SVfARG(newSVpvn_flags(name, nend - name,
1076                                 SVs_TEMP | is_utf8)),
1077                            SVfARG(packnamesv), SVfARG(packnamesv));
1078             }
1079         }
1080     }
1081     else if (autoload) {
1082         CV* const cv = GvCV(gv);
1083         if (!CvROOT(cv) && !CvXSUB(cv)) {
1084             GV* stubgv;
1085             GV* autogv;
1086
1087             if (CvANON(cv))
1088                 stubgv = gv;
1089             else {
1090                 stubgv = CvGV(cv);
1091                 if (GvCV(stubgv) != cv)         /* orphaned import */
1092                     stubgv = gv;
1093             }
1094             autogv = gv_autoload_pvn(GvSTASH(stubgv),
1095                                   GvNAME(stubgv), GvNAMELEN(stubgv),
1096                                   GV_AUTOLOAD_ISMETHOD
1097                                    | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1098             if (autogv)
1099                 gv = autogv;
1100         }
1101     }
1102
1103     return gv;
1104 }
1105
1106 GV*
1107 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1108 {
1109    char *namepv;
1110    STRLEN namelen;
1111    PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1112    namepv = SvPV(namesv, namelen);
1113    if (SvUTF8(namesv))
1114        flags |= SVf_UTF8;
1115    return gv_autoload_pvn(stash, namepv, namelen, flags);
1116 }
1117
1118 GV*
1119 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1120 {
1121    PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1122    return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1123 }
1124
1125 GV*
1126 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1127 {
1128     dVAR;
1129     GV* gv;
1130     CV* cv;
1131     HV* varstash;
1132     GV* vargv;
1133     SV* varsv;
1134     SV *packname = NULL;
1135     U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1136
1137     PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1138
1139     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1140         return NULL;
1141     if (stash) {
1142         if (SvTYPE(stash) < SVt_PVHV) {
1143             STRLEN packname_len = 0;
1144             const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1145             packname = newSVpvn_flags(packname_ptr, packname_len,
1146                                       SVs_TEMP | SvUTF8(stash));
1147             stash = NULL;
1148         }
1149         else
1150             packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1151     }
1152     if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8)))
1153         return NULL;
1154     cv = GvCV(gv);
1155
1156     if (!(CvROOT(cv) || CvXSUB(cv)))
1157         return NULL;
1158
1159     /*
1160      * Inheriting AUTOLOAD for non-methods works ... for now.
1161      */
1162     if (
1163         !(flags & GV_AUTOLOAD_ISMETHOD)
1164      && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1165     )
1166         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1167                          "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated",
1168                          SVfARG(packname),
1169                          SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
1170
1171     if (CvISXSUB(cv)) {
1172         /* rather than lookup/init $AUTOLOAD here
1173          * only to have the XSUB do another lookup for $AUTOLOAD
1174          * and split that value on the last '::',
1175          * pass along the same data via some unused fields in the CV
1176          */
1177         CvSTASH_set(cv, stash);
1178         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
1179         SvCUR_set(cv, len);
1180         if (is_utf8)
1181             SvUTF8_on(cv);
1182         return gv;
1183     }
1184
1185     /*
1186      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1187      * The subroutine's original name may not be "AUTOLOAD", so we don't
1188      * use that, but for lack of anything better we will use the sub's
1189      * original package to look up $AUTOLOAD.
1190      */
1191     varstash = GvSTASH(CvGV(cv));
1192     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1193     ENTER;
1194
1195     if (!isGV(vargv)) {
1196         gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1197 #ifdef PERL_DONT_CREATE_GVSV
1198         GvSV(vargv) = newSV(0);
1199 #endif
1200     }
1201     LEAVE;
1202     varsv = GvSVn(vargv);
1203     sv_setsv(varsv, packname);
1204     sv_catpvs(varsv, "::");
1205     /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1206        tainting if $FOO::AUTOLOAD was previously tainted, but is not now.  */
1207     sv_catpvn_mg(varsv, name, len);
1208     if (is_utf8)
1209         SvUTF8_on(varsv);
1210     return gv;
1211 }
1212
1213
1214 /* require_tie_mod() internal routine for requiring a module
1215  * that implements the logic of automatic ties like %! and %-
1216  *
1217  * The "gv" parameter should be the glob.
1218  * "varpv" holds the name of the var, used for error messages.
1219  * "namesv" holds the module name. Its refcount will be decremented.
1220  * "methpv" holds the method name to test for to check that things
1221  *   are working reasonably close to as expected.
1222  * "flags": if flag & 1 then save the scalar before loading.
1223  * For the protection of $! to work (it is set by this routine)
1224  * the sv slot must already be magicalized.
1225  */
1226 STATIC HV*
1227 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1228 {
1229     dVAR;
1230     HV* stash = gv_stashsv(namesv, 0);
1231
1232     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1233
1234     if (!stash || !(gv_fetchmethod(stash, methpv))) {
1235         SV *module = newSVsv(namesv);
1236         char varname = *varpv; /* varpv might be clobbered by load_module,
1237                                   so save it. For the moment it's always
1238                                   a single char. */
1239         dSP;
1240         ENTER;
1241         if ( flags & 1 )
1242             save_scalar(gv);
1243         PUSHSTACKi(PERLSI_MAGIC);
1244         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1245         POPSTACK;
1246         LEAVE;
1247         SPAGAIN;
1248         stash = gv_stashsv(namesv, 0);
1249         if (!stash)
1250             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
1251                     varname, SVfARG(namesv));
1252         else if (!gv_fetchmethod(stash, methpv))
1253             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
1254                     varname, SVfARG(namesv), methpv);
1255     }
1256     SvREFCNT_dec(namesv);
1257     return stash;
1258 }
1259
1260 /*
1261 =for apidoc gv_stashpv
1262
1263 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
1264 determine the length of C<name>, then calls C<gv_stashpvn()>.
1265
1266 =cut
1267 */
1268
1269 HV*
1270 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1271 {
1272     PERL_ARGS_ASSERT_GV_STASHPV;
1273     return gv_stashpvn(name, strlen(name), create);
1274 }
1275
1276 /*
1277 =for apidoc gv_stashpvn
1278
1279 Returns a pointer to the stash for a specified package.  The C<namelen>
1280 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
1281 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1282 created if it does not already exist.  If the package does not exist and
1283 C<flags> is 0 (or any other setting that does not create packages) then NULL
1284 is returned.
1285
1286
1287 =cut
1288 */
1289
1290 HV*
1291 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1292 {
1293     char smallbuf[128];
1294     char *tmpbuf;
1295     HV *stash;
1296     GV *tmpgv;
1297     U32 tmplen = namelen + 2;
1298
1299     PERL_ARGS_ASSERT_GV_STASHPVN;
1300
1301     if (tmplen <= sizeof smallbuf)
1302         tmpbuf = smallbuf;
1303     else
1304         Newx(tmpbuf, tmplen, char);
1305     Copy(name, tmpbuf, namelen, char);
1306     tmpbuf[namelen]   = ':';
1307     tmpbuf[namelen+1] = ':';
1308     tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1309     if (tmpbuf != smallbuf)
1310         Safefree(tmpbuf);
1311     if (!tmpgv)
1312         return NULL;
1313     stash = GvHV(tmpgv);
1314     if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1315     assert(stash);
1316     if (!HvNAME_get(stash)) {
1317         hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1318
1319         /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1320         /* If the containing stash has multiple effective
1321            names, see that this one gets them, too. */
1322         if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1323             mro_package_moved(stash, NULL, tmpgv, 1);
1324     }
1325     return stash;
1326 }
1327
1328 /*
1329 =for apidoc gv_stashsv
1330
1331 Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
1332
1333 =cut
1334 */
1335
1336 HV*
1337 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1338 {
1339     STRLEN len;
1340     const char * const ptr = SvPV_const(sv,len);
1341
1342     PERL_ARGS_ASSERT_GV_STASHSV;
1343
1344     return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
1345 }
1346
1347
1348 GV *
1349 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1350     PERL_ARGS_ASSERT_GV_FETCHPV;
1351     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1352 }
1353
1354 GV *
1355 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1356     STRLEN len;
1357     const char * const nambeg =
1358        SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1359     PERL_ARGS_ASSERT_GV_FETCHSV;
1360     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1361 }
1362
1363 STATIC void
1364 S_gv_magicalize_isa(pTHX_ GV *gv)
1365 {
1366     AV* av;
1367
1368     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1369
1370     av = GvAVn(gv);
1371     GvMULTI_on(gv);
1372     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1373              NULL, 0);
1374 }
1375
1376 STATIC void
1377 S_gv_magicalize_overload(pTHX_ GV *gv)
1378 {
1379     HV* hv;
1380
1381     PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
1382
1383     hv = GvHVn(gv);
1384     GvMULTI_on(gv);
1385     hv_magic(hv, NULL, PERL_MAGIC_overload);
1386 }
1387
1388 GV *
1389 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
1390                        const svtype sv_type)
1391 {
1392     dVAR;
1393     register const char *name = nambeg;
1394     register GV *gv = NULL;
1395     GV**gvp;
1396     I32 len;
1397     register const char *name_cursor;
1398     HV *stash = NULL;
1399     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
1400     const I32 no_expand = flags & GV_NOEXPAND;
1401     const I32 add = flags & ~GV_NOADD_MASK;
1402     const U32 is_utf8 = flags & SVf_UTF8;
1403     bool addmg = !!(flags & GV_ADDMG);
1404     const char *const name_end = nambeg + full_len;
1405     const char *const name_em1 = name_end - 1;
1406     U32 faking_it;
1407
1408     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1409
1410     if (flags & GV_NOTQUAL) {
1411         /* Caller promised that there is no stash, so we can skip the check. */
1412         len = full_len;
1413         goto no_stash;
1414     }
1415
1416     if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
1417         /* accidental stringify on a GV? */
1418         name++;
1419     }
1420
1421     for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1422         if (name_cursor < name_em1 &&
1423             ((*name_cursor == ':'
1424              && name_cursor[1] == ':')
1425             || *name_cursor == '\''))
1426         {
1427             if (!stash)
1428                 stash = PL_defstash;
1429             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1430                 return NULL;
1431
1432             len = name_cursor - name;
1433             if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1434                 const char *key;
1435                 if (*name_cursor == ':') {
1436                     key = name;
1437                     len += 2;
1438                 } else {
1439                     char *tmpbuf;
1440                     Newx(tmpbuf, len+2, char);
1441                     Copy(name, tmpbuf, len, char);
1442                     tmpbuf[len++] = ':';
1443                     tmpbuf[len++] = ':';
1444                     key = tmpbuf;
1445                 }
1446                 gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add);
1447                 gv = gvp ? *gvp : NULL;
1448                 if (gv && gv != (const GV *)&PL_sv_undef) {
1449                     if (SvTYPE(gv) != SVt_PVGV)
1450                         gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8);
1451                     else
1452                         GvMULTI_on(gv);
1453                 }
1454                 if (key != name)
1455                     Safefree(key);
1456                 if (!gv || gv == (const GV *)&PL_sv_undef)
1457                     return NULL;
1458
1459                 if (!(stash = GvHV(gv)))
1460                 {
1461                     stash = GvHV(gv) = newHV();
1462                     if (!HvNAME_get(stash)) {
1463                         if (GvSTASH(gv) == PL_defstash && len == 6
1464                          && strnEQ(name, "CORE", 4))
1465                             hv_name_set(stash, "CORE", 4, 0);
1466                         else
1467                             hv_name_set(
1468                                 stash, nambeg, name_cursor-nambeg, is_utf8
1469                             );
1470                         /* If the containing stash has multiple effective
1471                            names, see that this one gets them, too. */
1472                         if (HvAUX(GvSTASH(gv))->xhv_name_count)
1473                             mro_package_moved(stash, NULL, gv, 1);
1474                     }
1475                 }
1476                 else if (!HvNAME_get(stash))
1477                     hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8);
1478             }
1479
1480             if (*name_cursor == ':')
1481                 name_cursor++;
1482             name = name_cursor+1;
1483             if (name == name_end)
1484                 return gv
1485                     ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1486         }
1487     }
1488     len = name_cursor - name;
1489
1490     /* No stash in name, so see how we can default */
1491
1492     if (!stash) {
1493     no_stash:
1494         if (len && isIDFIRST_lazy(name)) {
1495             bool global = FALSE;
1496
1497             switch (len) {
1498             case 1:
1499                 if (*name == '_')
1500                     global = TRUE;
1501                 break;
1502             case 3:
1503                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1504                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1505                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1506                     global = TRUE;
1507                 break;
1508             case 4:
1509                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1510                     && name[3] == 'V')
1511                     global = TRUE;
1512                 break;
1513             case 5:
1514                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1515                     && name[3] == 'I' && name[4] == 'N')
1516                     global = TRUE;
1517                 break;
1518             case 6:
1519                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1520                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1521                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1522                     global = TRUE;
1523                 break;
1524             case 7:
1525                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1526                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1527                     && name[6] == 'T')
1528                     global = TRUE;
1529                 break;
1530             }
1531
1532             if (global)
1533                 stash = PL_defstash;
1534             else if (IN_PERL_COMPILETIME) {
1535                 stash = PL_curstash;
1536                 if (add && (PL_hints & HINT_STRICT_VARS) &&
1537                     sv_type != SVt_PVCV &&
1538                     sv_type != SVt_PVGV &&
1539                     sv_type != SVt_PVFM &&
1540                     sv_type != SVt_PVIO &&
1541                     !(len == 1 && sv_type == SVt_PV &&
1542                       (*name == 'a' || *name == 'b')) )
1543                 {
1544                     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0);
1545                     if (!gvp ||
1546                         *gvp == (const GV *)&PL_sv_undef ||
1547                         SvTYPE(*gvp) != SVt_PVGV)
1548                     {
1549                         stash = NULL;
1550                     }
1551                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1552                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1553                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1554                     {
1555                         SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8);
1556                         /* diag_listed_as: Variable "%s" is not imported%s */
1557                         Perl_ck_warner_d(
1558                             aTHX_ packWARN(WARN_MISC),
1559                             "Variable \"%c%"SVf"\" is not imported",
1560                             sv_type == SVt_PVAV ? '@' :
1561                             sv_type == SVt_PVHV ? '%' : '$',
1562                             SVfARG(namesv));
1563                         if (GvCVu(*gvp))
1564                             Perl_ck_warner_d(
1565                                 aTHX_ packWARN(WARN_MISC),
1566                                 "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv)
1567                             );
1568                         stash = NULL;
1569                     }
1570                 }
1571             }
1572             else
1573                 stash = CopSTASH(PL_curcop);
1574         }
1575         else
1576             stash = PL_defstash;
1577     }
1578
1579     /* By this point we should have a stash and a name */
1580
1581     if (!stash) {
1582         if (add) {
1583             SV * const err = Perl_mess(aTHX_
1584                  "Global symbol \"%s%"SVf"\" requires explicit package name",
1585                  (sv_type == SVt_PV ? "$"
1586                   : sv_type == SVt_PVAV ? "@"
1587                   : sv_type == SVt_PVHV ? "%"
1588                   : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
1589             GV *gv;
1590             if (USE_UTF8_IN_NAMES)
1591                 SvUTF8_on(err);
1592             qerror(err);
1593             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1594             if(!gv) {
1595                 /* symbol table under destruction */
1596                 return NULL;
1597             }
1598             stash = GvHV(gv);
1599         }
1600         else
1601             return NULL;
1602     }
1603
1604     if (!SvREFCNT(stash))       /* symbol table under destruction */
1605         return NULL;
1606
1607     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
1608     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1609         if (addmg) gv = (GV *)newSV(0);
1610         else return NULL;
1611     }
1612     else gv = *gvp, addmg = 0;
1613     /* From this point on, addmg means gv has not been inserted in the
1614        symtab yet. */
1615
1616     if (SvTYPE(gv) == SVt_PVGV) {
1617         if (add) {
1618             GvMULTI_on(gv);
1619             gv_init_svtype(gv, sv_type);
1620             if (len == 1 && stash == PL_defstash
1621                 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1622                 if (*name == '!')
1623                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1624                 else if (*name == '-' || *name == '+')
1625                     require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1626             }
1627             else if (len == 3 && sv_type == SVt_PVAV
1628                   && strnEQ(name, "ISA", 3)
1629                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1630                 gv_magicalize_isa(gv);
1631         }
1632         return gv;
1633     } else if (no_init) {
1634         assert(!addmg);
1635         return gv;
1636     } else if (no_expand && SvROK(gv)) {
1637         assert(!addmg);
1638         return gv;
1639     }
1640
1641     /* Adding a new symbol.
1642        Unless of course there was already something non-GV here, in which case
1643        we want to behave as if there was always a GV here, containing some sort
1644        of subroutine.
1645        Otherwise we run the risk of creating things like GvIO, which can cause
1646        subtle bugs. eg the one that tripped up SQL::Translator  */
1647
1648     faking_it = SvOK(gv);
1649
1650     if (add & GV_ADDWARN)
1651         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
1652                 SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
1653     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
1654
1655     if ( isIDFIRST_lazy_if(name, is_utf8)
1656                 && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
1657         GvMULTI_on(gv) ;
1658
1659     /* set up magic where warranted */
1660     if (stash != PL_defstash) { /* not the main stash */
1661         /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
1662            and VERSION. All the others apply only to the main stash or to
1663            CORE (which is checked right after this). */
1664         if (len > 2) {
1665             const char * const name2 = name + 1;
1666             switch (*name) {
1667             case 'E':
1668                 if (strnEQ(name2, "XPORT", 5))
1669                     GvMULTI_on(gv);
1670                 break;
1671             case 'I':
1672                 if (strEQ(name2, "SA"))
1673                     gv_magicalize_isa(gv);
1674                 break;
1675             case 'O':
1676                 if (strEQ(name2, "VERLOAD"))
1677                     gv_magicalize_overload(gv);
1678                 break;
1679             case 'V':
1680                 if (strEQ(name2, "ERSION"))
1681                     GvMULTI_on(gv);
1682                 break;
1683             default:
1684                 goto try_core;
1685             }
1686             goto add_magical_gv;
1687         }
1688       try_core:
1689         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1690           /* Avoid null warning: */
1691           const char * const stashname = HvNAME(stash); assert(stashname);
1692           if (strnEQ(stashname, "CORE", 4)
1693            && S_maybe_add_coresub(aTHX_
1694                 addmg ? stash : 0, gv, name, len, nambeg, full_len
1695               ))
1696             addmg = 0;
1697         }
1698     }
1699     else if (len > 1) {
1700 #ifndef EBCDIC
1701         if (*name > 'V' ) {
1702             NOOP;
1703             /* Nothing else to do.
1704                The compiler will probably turn the switch statement into a
1705                branch table. Make sure we avoid even that small overhead for
1706                the common case of lower case variable names.  */
1707         } else
1708 #endif
1709         {
1710             const char * const name2 = name + 1;
1711             switch (*name) {
1712             case 'A':
1713                 if (strEQ(name2, "RGV")) {
1714                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1715                 }
1716                 else if (strEQ(name2, "RGVOUT")) {
1717                     GvMULTI_on(gv);
1718                 }
1719                 break;
1720             case 'E':
1721                 if (strnEQ(name2, "XPORT", 5))
1722                     GvMULTI_on(gv);
1723                 break;
1724             case 'I':
1725                 if (strEQ(name2, "SA")) {
1726                     gv_magicalize_isa(gv);
1727                 }
1728                 break;
1729             case 'O':
1730                 if (strEQ(name2, "VERLOAD")) {
1731                     gv_magicalize_overload(gv);
1732                 }
1733                 break;
1734             case 'S':
1735                 if (strEQ(name2, "IG")) {
1736                     HV *hv;
1737                     I32 i;
1738                     if (!PL_psig_name) {
1739                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1740                         Newxz(PL_psig_pend, SIG_SIZE, int);
1741                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1742                     } else {
1743                         /* I think that the only way to get here is to re-use an
1744                            embedded perl interpreter, where the previous
1745                            use didn't clean up fully because
1746                            PL_perl_destruct_level was 0. I'm not sure that we
1747                            "support" that, in that I suspect in that scenario
1748                            there are sufficient other garbage values left in the
1749                            interpreter structure that something else will crash
1750                            before we get here. I suspect that this is one of
1751                            those "doctor, it hurts when I do this" bugs.  */
1752                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1753                         Zero(PL_psig_pend, SIG_SIZE, int);
1754                     }
1755                     GvMULTI_on(gv);
1756                     hv = GvHVn(gv);
1757                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1758                     for (i = 1; i < SIG_SIZE; i++) {
1759                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1760                         if (init)
1761                             sv_setsv(*init, &PL_sv_undef);
1762                     }
1763                 }
1764                 break;
1765             case 'V':
1766                 if (strEQ(name2, "ERSION"))
1767                     GvMULTI_on(gv);
1768                 break;
1769             case '\003':        /* $^CHILD_ERROR_NATIVE */
1770                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1771                     goto magicalize;
1772                 break;
1773             case '\005':        /* $^ENCODING */
1774                 if (strEQ(name2, "NCODING"))
1775                     goto magicalize;
1776                 break;
1777             case '\007':        /* $^GLOBAL_PHASE */
1778                 if (strEQ(name2, "LOBAL_PHASE"))
1779                     goto ro_magicalize;
1780                 break;
1781             case '\015':        /* $^MATCH */
1782                 if (strEQ(name2, "ATCH"))
1783                     goto magicalize;
1784             case '\017':        /* $^OPEN */
1785                 if (strEQ(name2, "PEN"))
1786                     goto magicalize;
1787                 break;
1788             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1789                 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1790                     goto magicalize;
1791                 break;
1792             case '\024':        /* ${^TAINT} */
1793                 if (strEQ(name2, "AINT"))
1794                     goto ro_magicalize;
1795                 break;
1796             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1797                 if (strEQ(name2, "NICODE"))
1798                     goto ro_magicalize;
1799                 if (strEQ(name2, "TF8LOCALE"))
1800                     goto ro_magicalize;
1801                 if (strEQ(name2, "TF8CACHE"))
1802                     goto magicalize;
1803                 break;
1804             case '\027':        /* $^WARNING_BITS */
1805                 if (strEQ(name2, "ARNING_BITS"))
1806                     goto magicalize;
1807                 break;
1808             case '1':
1809             case '2':
1810             case '3':
1811             case '4':
1812             case '5':
1813             case '6':
1814             case '7':
1815             case '8':
1816             case '9':
1817             {
1818                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1819                    this test  */
1820                 /* This snippet is taken from is_gv_magical */
1821                 const char *end = name + len;
1822                 while (--end > name) {
1823                     if (!isDIGIT(*end)) goto add_magical_gv;
1824                 }
1825                 goto magicalize;
1826             }
1827             }
1828         }
1829     } else {
1830         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1831            be case '\0' in this switch statement (ie a default case)  */
1832         switch (*name) {
1833         case '&':               /* $& */
1834         case '`':               /* $` */
1835         case '\'':              /* $' */
1836             if (
1837                 sv_type == SVt_PVAV ||
1838                 sv_type == SVt_PVHV ||
1839                 sv_type == SVt_PVCV ||
1840                 sv_type == SVt_PVFM ||
1841                 sv_type == SVt_PVIO
1842                 ) { break; }
1843             PL_sawampersand = TRUE;
1844             goto magicalize;
1845
1846         case ':':               /* $: */
1847             sv_setpv(GvSVn(gv),PL_chopset);
1848             goto magicalize;
1849
1850         case '?':               /* $? */
1851 #ifdef COMPLEX_STATUS
1852             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1853 #endif
1854             goto magicalize;
1855
1856         case '!':               /* $! */
1857             GvMULTI_on(gv);
1858             /* If %! has been used, automatically load Errno.pm. */
1859
1860             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1861
1862             /* magicalization must be done before require_tie_mod is called */
1863             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1864                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1865
1866             break;
1867         case '-':               /* $- */
1868         case '+':               /* $+ */
1869         GvMULTI_on(gv); /* no used once warnings here */
1870         {
1871             AV* const av = GvAVn(gv);
1872             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1873
1874             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1875             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1876             if (avc)
1877                 SvREADONLY_on(GvSVn(gv));
1878             SvREADONLY_on(av);
1879
1880             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1881                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1882
1883             break;
1884         }
1885         case '*':               /* $* */
1886         case '#':               /* $# */
1887             if (sv_type == SVt_PV)
1888                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1889                                  "$%c is no longer supported", *name);
1890             break;
1891         case '|':               /* $| */
1892             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1893             goto magicalize;
1894
1895         case '\010':    /* $^H */
1896             {
1897                 HV *const hv = GvHVn(gv);
1898                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1899             }
1900             goto magicalize;
1901         case '\023':    /* $^S */
1902         ro_magicalize:
1903             SvREADONLY_on(GvSVn(gv));
1904             /* FALL THROUGH */
1905         case '0':               /* $0 */
1906         case '1':               /* $1 */
1907         case '2':               /* $2 */
1908         case '3':               /* $3 */
1909         case '4':               /* $4 */
1910         case '5':               /* $5 */
1911         case '6':               /* $6 */
1912         case '7':               /* $7 */
1913         case '8':               /* $8 */
1914         case '9':               /* $9 */
1915         case '[':               /* $[ */
1916         case '^':               /* $^ */
1917         case '~':               /* $~ */
1918         case '=':               /* $= */
1919         case '%':               /* $% */
1920         case '.':               /* $. */
1921         case '(':               /* $( */
1922         case ')':               /* $) */
1923         case '<':               /* $< */
1924         case '>':               /* $> */
1925         case '\\':              /* $\ */
1926         case '/':               /* $/ */
1927         case '$':               /* $$ */
1928         case '\001':    /* $^A */
1929         case '\003':    /* $^C */
1930         case '\004':    /* $^D */
1931         case '\005':    /* $^E */
1932         case '\006':    /* $^F */
1933         case '\011':    /* $^I, NOT \t in EBCDIC */
1934         case '\016':    /* $^N */
1935         case '\017':    /* $^O */
1936         case '\020':    /* $^P */
1937         case '\024':    /* $^T */
1938         case '\027':    /* $^W */
1939         magicalize:
1940             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1941             break;
1942
1943         case '\014':    /* $^L */
1944             sv_setpvs(GvSVn(gv),"\f");
1945             PL_formfeed = GvSVn(gv);
1946             break;
1947         case ';':               /* $; */
1948             sv_setpvs(GvSVn(gv),"\034");
1949             break;
1950         case ']':               /* $] */
1951         {
1952             SV * const sv = GvSV(gv);
1953             if (!sv_derived_from(PL_patchlevel, "version"))
1954                 upg_version(PL_patchlevel, TRUE);
1955             GvSV(gv) = vnumify(PL_patchlevel);
1956             SvREADONLY_on(GvSV(gv));
1957             SvREFCNT_dec(sv);
1958         }
1959         break;
1960         case '\026':    /* $^V */
1961         {
1962             SV * const sv = GvSV(gv);
1963             GvSV(gv) = new_version(PL_patchlevel);
1964             SvREADONLY_on(GvSV(gv));
1965             SvREFCNT_dec(sv);
1966         }
1967         break;
1968         }
1969     }
1970   add_magical_gv:
1971     if (addmg) {
1972         if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
1973              GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
1974            ))
1975             (void)hv_store(stash,name,len,(SV *)gv,0);
1976         else SvREFCNT_dec(gv), gv = NULL;
1977     }
1978     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
1979     return gv;
1980 }
1981
1982 void
1983 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1984 {
1985     SV *name;
1986     const HV * const hv = GvSTASH(gv);
1987
1988     PERL_ARGS_ASSERT_GV_FULLNAME4;
1989
1990     if (!hv) {
1991         SvOK_off(sv);
1992         return;
1993     }
1994     sv_setpv(sv, prefix ? prefix : "");
1995
1996     name = HvNAME_get(hv)
1997             ? sv_2mortal(newSVhek(HvNAME_HEK(hv)))
1998             : newSVpvn_flags( "__ANON__", 8, SVs_TEMP );
1999
2000     if (keepmain || strnNE(SvPV_nolen(name), "main", SvCUR(name))) {
2001         sv_catsv(sv,name);
2002         sv_catpvs(sv,"::");
2003     }
2004     sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2005 }
2006
2007 void
2008 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2009 {
2010     const GV * const egv = GvEGVx(gv);
2011
2012     PERL_ARGS_ASSERT_GV_EFULLNAME4;
2013
2014     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2015 }
2016
2017 void
2018 Perl_gv_check(pTHX_ const HV *stash)
2019 {
2020     dVAR;
2021     register I32 i;
2022
2023     PERL_ARGS_ASSERT_GV_CHECK;
2024
2025     if (!HvARRAY(stash))
2026         return;
2027     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2028         const HE *entry;
2029         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2030             register GV *gv;
2031             HV *hv;
2032             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2033                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2034             {
2035                 if (hv != PL_defstash && hv != stash)
2036                      gv_check(hv);              /* nested package */
2037             }
2038             else if ( *HeKEY(entry) != '_'
2039                         && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2040                 const char *file;
2041                 gv = MUTABLE_GV(HeVAL(entry));
2042                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2043                     continue;
2044                 file = GvFILE(gv);
2045                 CopLINE_set(PL_curcop, GvLINE(gv));
2046 #ifdef USE_ITHREADS
2047                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
2048 #else
2049                 CopFILEGV(PL_curcop)
2050                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2051 #endif
2052                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2053                         "Name \"%"HEKf"::%"HEKf
2054                         "\" used only once: possible typo",
2055                             HEKfARG(HvNAME_HEK(stash)),
2056                             HEKfARG(GvNAME_HEK(gv)));
2057             }
2058         }
2059     }
2060 }
2061
2062 GV *
2063 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2064 {
2065     dVAR;
2066     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2067
2068     return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
2069                                     SVfARG(newSVpvn_flags(pack, strlen(pack),
2070                                             SVs_TEMP | flags)),
2071                                 (long)PL_gensym++),
2072                       GV_ADD, SVt_PVGV);
2073 }
2074
2075 /* hopefully this is only called on local symbol table entries */
2076
2077 GP*
2078 Perl_gp_ref(pTHX_ GP *gp)
2079 {
2080     dVAR;
2081     if (!gp)
2082         return NULL;
2083     gp->gp_refcnt++;
2084     if (gp->gp_cv) {
2085         if (gp->gp_cvgen) {
2086             /* If the GP they asked for a reference to contains
2087                a method cache entry, clear it first, so that we
2088                don't infect them with our cached entry */
2089             SvREFCNT_dec(gp->gp_cv);
2090             gp->gp_cv = NULL;
2091             gp->gp_cvgen = 0;
2092         }
2093     }
2094     return gp;
2095 }
2096
2097 void
2098 Perl_gp_free(pTHX_ GV *gv)
2099 {
2100     dVAR;
2101     GP* gp;
2102     int attempts = 100;
2103
2104     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2105         return;
2106     if (gp->gp_refcnt == 0) {
2107         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2108                          "Attempt to free unreferenced glob pointers"
2109                          pTHX__FORMAT pTHX__VALUE);
2110         return;
2111     }
2112     if (--gp->gp_refcnt > 0) {
2113         if (gp->gp_egv == gv)
2114             gp->gp_egv = 0;
2115         GvGP_set(gv, NULL);
2116         return;
2117     }
2118
2119     while (1) {
2120       /* Copy and null out all the glob slots, so destructors do not see
2121          freed SVs. */
2122       HEK * const file_hek = gp->gp_file_hek;
2123       SV  * const sv       = gp->gp_sv;
2124       AV  * const av       = gp->gp_av;
2125       HV  * const hv       = gp->gp_hv;
2126       IO  * const io       = gp->gp_io;
2127       CV  * const cv       = gp->gp_cv;
2128       CV  * const form     = gp->gp_form;
2129
2130       gp->gp_file_hek = NULL;
2131       gp->gp_sv       = NULL;
2132       gp->gp_av       = NULL;
2133       gp->gp_hv       = NULL;
2134       gp->gp_io       = NULL;
2135       gp->gp_cv       = NULL;
2136       gp->gp_form     = NULL;
2137
2138       if (file_hek)
2139         unshare_hek(file_hek);
2140
2141       SvREFCNT_dec(sv);
2142       SvREFCNT_dec(av);
2143       /* FIXME - another reference loop GV -> symtab -> GV ?
2144          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2145       if (hv && SvTYPE(hv) == SVt_PVHV) {
2146         const HEK *hvname_hek = HvNAME_HEK(hv);
2147         if (PL_stashcache && hvname_hek)
2148            (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2149                       (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2150                       G_DISCARD);
2151         SvREFCNT_dec(hv);
2152       }
2153       SvREFCNT_dec(io);
2154       SvREFCNT_dec(cv);
2155       SvREFCNT_dec(form);
2156
2157       if (!gp->gp_file_hek
2158        && !gp->gp_sv
2159        && !gp->gp_av
2160        && !gp->gp_hv
2161        && !gp->gp_io
2162        && !gp->gp_cv
2163        && !gp->gp_form) break;
2164
2165       if (--attempts == 0) {
2166         Perl_die(aTHX_
2167           "panic: gp_free failed to free glob pointer - "
2168           "something is repeatedly re-creating entries"
2169         );
2170       }
2171     }
2172
2173     Safefree(gp);
2174     GvGP_set(gv, NULL);
2175 }
2176
2177 int
2178 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2179 {
2180     AMT * const amtp = (AMT*)mg->mg_ptr;
2181     PERL_UNUSED_ARG(sv);
2182
2183     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2184
2185     if (amtp && AMT_AMAGIC(amtp)) {
2186         int i;
2187         for (i = 1; i < NofAMmeth; i++) {
2188             CV * const cv = amtp->table[i];
2189             if (cv) {
2190                 SvREFCNT_dec(MUTABLE_SV(cv));
2191                 amtp->table[i] = NULL;
2192             }
2193         }
2194     }
2195  return 0;
2196 }
2197
2198 /* Updates and caches the CV's */
2199 /* Returns:
2200  * 1 on success and there is some overload
2201  * 0 if there is no overload
2202  * -1 if some error occurred and it couldn't croak
2203  */
2204
2205 int
2206 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2207 {
2208   dVAR;
2209   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2210   AMT amt;
2211   const struct mro_meta* stash_meta = HvMROMETA(stash);
2212   U32 newgen;
2213
2214   PERL_ARGS_ASSERT_GV_AMUPDATE;
2215
2216   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2217   if (mg) {
2218       const AMT * const amtp = (AMT*)mg->mg_ptr;
2219       if (amtp->was_ok_am == PL_amagic_generation
2220           && amtp->was_ok_sub == newgen) {
2221           return AMT_OVERLOADED(amtp) ? 1 : 0;
2222       }
2223       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2224   }
2225
2226   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2227
2228   Zero(&amt,1,AMT);
2229   amt.was_ok_am = PL_amagic_generation;
2230   amt.was_ok_sub = newgen;
2231   amt.fallback = AMGfallNO;
2232   amt.flags = 0;
2233
2234   {
2235     int filled = 0, have_ovl = 0;
2236     int i, lim = 1;
2237
2238     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2239
2240     /* Try to find via inheritance. */
2241     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2242     SV * const sv = gv ? GvSV(gv) : NULL;
2243     CV* cv;
2244
2245     if (!gv)
2246         lim = DESTROY_amg;              /* Skip overloading entries. */
2247 #ifdef PERL_DONT_CREATE_GVSV
2248     else if (!sv) {
2249         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2250     }
2251 #endif
2252     else if (SvTRUE(sv))
2253         amt.fallback=AMGfallYES;
2254     else if (SvOK(sv))
2255         amt.fallback=AMGfallNEVER;
2256
2257     for (i = 1; i < lim; i++)
2258         amt.table[i] = NULL;
2259     for (; i < NofAMmeth; i++) {
2260         const char * const cooky = PL_AMG_names[i];
2261         /* Human-readable form, for debugging: */
2262         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2263         const STRLEN l = PL_AMG_namelens[i];
2264
2265         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2266                      cp, HvNAME_get(stash)) );
2267         /* don't fill the cache while looking up!
2268            Creation of inheritance stubs in intermediate packages may
2269            conflict with the logic of runtime method substitution.
2270            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2271            then we could have created stubs for "(+0" in A and C too.
2272            But if B overloads "bool", we may want to use it for
2273            numifying instead of C's "+0". */
2274         if (i >= DESTROY_amg)
2275             gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
2276         else                            /* Autoload taken care of below */
2277             gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2278         cv = 0;
2279         if (gv && (cv = GvCV(gv))) {
2280             if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2281               const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2282               if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2283                && strEQ(hvname, "overload")) {
2284                 /* This is a hack to support autoloading..., while
2285                    knowing *which* methods were declared as overloaded. */
2286                 /* GvSV contains the name of the method. */
2287                 GV *ngv = NULL;
2288                 SV *gvsv = GvSV(gv);
2289
2290                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2291                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2292                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2293                 if (!gvsv || !SvPOK(gvsv)
2294                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2295                 {
2296                     /* Can be an import stub (created by "can"). */
2297                     if (destructing) {
2298                         return -1;
2299                     }
2300                     else {
2301                         const SV * const name = (gvsv && SvPOK(gvsv))
2302                                                     ? gvsv
2303                                                     : newSVpvs_flags("???", SVs_TEMP);
2304                         Perl_croak(aTHX_ "%s method \"%"SVf256
2305                                     "\" overloading \"%s\" "\
2306                                     "in package \"%"HEKf256"\"",
2307                                    (GvCVGEN(gv) ? "Stub found while resolving"
2308                                     : "Can't resolve"),
2309                                    SVfARG(name), cp,
2310                                    HEKfARG(
2311                                         HvNAME_HEK(stash)
2312                                    ));
2313                     }
2314                 }
2315                 cv = GvCV(gv = ngv);
2316               }
2317             }
2318             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2319                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2320                          GvNAME(CvGV(cv))) );
2321             filled = 1;
2322             if (i < DESTROY_amg)
2323                 have_ovl = 1;
2324         } else if (gv) {                /* Autoloaded... */
2325             cv = MUTABLE_CV(gv);
2326             filled = 1;
2327         }
2328         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2329     }
2330     if (filled) {
2331       AMT_AMAGIC_on(&amt);
2332       if (have_ovl)
2333           AMT_OVERLOADED_on(&amt);
2334       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2335                                                 (char*)&amt, sizeof(AMT));
2336       return have_ovl;
2337     }
2338   }
2339   /* Here we have no table: */
2340   /* no_table: */
2341   AMT_AMAGIC_off(&amt);
2342   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2343                                                 (char*)&amt, sizeof(AMTS));
2344   return 0;
2345 }
2346
2347
2348 CV*
2349 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2350 {
2351     dVAR;
2352     MAGIC *mg;
2353     AMT *amtp;
2354     U32 newgen;
2355     struct mro_meta* stash_meta;
2356
2357     if (!stash || !HvNAME_get(stash))
2358         return NULL;
2359
2360     stash_meta = HvMROMETA(stash);
2361     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2362
2363     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2364     if (!mg) {
2365       do_update:
2366         /* If we're looking up a destructor to invoke, we must avoid
2367          * that Gv_AMupdate croaks, because we might be dying already */
2368         if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2369             /* and if it didn't found a destructor, we fall back
2370              * to a simpler method that will only look for the
2371              * destructor instead of the whole magic */
2372             if (id == DESTROY_amg) {
2373                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2374                 if (gv)
2375                     return GvCV(gv);
2376             }
2377             return NULL;
2378         }
2379         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2380     }
2381     assert(mg);
2382     amtp = (AMT*)mg->mg_ptr;
2383     if ( amtp->was_ok_am != PL_amagic_generation
2384          || amtp->was_ok_sub != newgen )
2385         goto do_update;
2386     if (AMT_AMAGIC(amtp)) {
2387         CV * const ret = amtp->table[id];
2388         if (ret && isGV(ret)) {         /* Autoloading stab */
2389             /* Passing it through may have resulted in a warning
2390                "Inherited AUTOLOAD for a non-method deprecated", since
2391                our caller is going through a function call, not a method call.
2392                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2393             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2394
2395             if (gv && GvCV(gv))
2396                 return GvCV(gv);
2397         }
2398         return ret;
2399     }
2400
2401     return NULL;
2402 }
2403
2404
2405 /* Implement tryAMAGICun_MG macro.
2406    Do get magic, then see if the stack arg is overloaded and if so call it.
2407    Flags:
2408         AMGf_set     return the arg using SETs rather than assigning to
2409                      the targ
2410         AMGf_numeric apply sv_2num to the stack arg.
2411 */
2412
2413 bool
2414 Perl_try_amagic_un(pTHX_ int method, int flags) {
2415     dVAR;
2416     dSP;
2417     SV* tmpsv;
2418     SV* const arg = TOPs;
2419
2420     SvGETMAGIC(arg);
2421
2422     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2423                                               AMGf_noright | AMGf_unary))) {
2424         if (flags & AMGf_set) {
2425             SETs(tmpsv);
2426         }
2427         else {
2428             dTARGET;
2429             if (SvPADMY(TARG)) {
2430                 sv_setsv(TARG, tmpsv);
2431                 SETTARG;
2432             }
2433             else
2434                 SETs(tmpsv);
2435         }
2436         PUTBACK;
2437         return TRUE;
2438     }
2439
2440     if ((flags & AMGf_numeric) && SvROK(arg))
2441         *sp = sv_2num(arg);
2442     return FALSE;
2443 }
2444
2445
2446 /* Implement tryAMAGICbin_MG macro.
2447    Do get magic, then see if the two stack args are overloaded and if so
2448    call it.
2449    Flags:
2450         AMGf_set     return the arg using SETs rather than assigning to
2451                      the targ
2452         AMGf_assign  op may be called as mutator (eg +=)
2453         AMGf_numeric apply sv_2num to the stack arg.
2454 */
2455
2456 bool
2457 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2458     dVAR;
2459     dSP;
2460     SV* const left = TOPm1s;
2461     SV* const right = TOPs;
2462
2463     SvGETMAGIC(left);
2464     if (left != right)
2465         SvGETMAGIC(right);
2466
2467     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2468         SV * const tmpsv = amagic_call(left, right, method,
2469                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2470         if (tmpsv) {
2471             if (flags & AMGf_set) {
2472                 (void)POPs;
2473                 SETs(tmpsv);
2474             }
2475             else {
2476                 dATARGET;
2477                 (void)POPs;
2478                 if (opASSIGN || SvPADMY(TARG)) {
2479                     sv_setsv(TARG, tmpsv);
2480                     SETTARG;
2481                 }
2482                 else
2483                     SETs(tmpsv);
2484             }
2485             PUTBACK;
2486             return TRUE;
2487         }
2488     }
2489     if(left==right && SvGMAGICAL(left)) {
2490         SV * const left = sv_newmortal();
2491         *(sp-1) = left;
2492         /* Print the uninitialized warning now, so it includes the vari-
2493            able name. */
2494         if (!SvOK(right)) {
2495             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2496             sv_setsv_flags(left, &PL_sv_no, 0);
2497         }
2498         else sv_setsv_flags(left, right, 0);
2499         SvGETMAGIC(right);
2500     }
2501     if (flags & AMGf_numeric) {
2502         if (SvROK(TOPm1s))
2503             *(sp-1) = sv_2num(TOPm1s);
2504         if (SvROK(right))
2505             *sp     = sv_2num(right);
2506     }
2507     return FALSE;
2508 }
2509
2510 SV *
2511 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2512     SV *tmpsv = NULL;
2513
2514     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2515
2516     while (SvAMAGIC(ref) &&
2517            (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2518                                 AMGf_noright | AMGf_unary))) {
2519         if (!SvROK(tmpsv))
2520             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2521         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2522             /* Bail out if it returns us the same reference.  */
2523             return tmpsv;
2524         }
2525         ref = tmpsv;
2526     }
2527     return tmpsv ? tmpsv : ref;
2528 }
2529
2530 SV*
2531 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2532 {
2533   dVAR;
2534   MAGIC *mg;
2535   CV *cv=NULL;
2536   CV **cvp=NULL, **ocvp=NULL;
2537   AMT *amtp=NULL, *oamtp=NULL;
2538   int off = 0, off1, lr = 0, notfound = 0;
2539   int postpr = 0, force_cpy = 0;
2540   int assign = AMGf_assign & flags;
2541   const int assignshift = assign ? 1 : 0;
2542   int use_default_op = 0;
2543 #ifdef DEBUGGING
2544   int fl=0;
2545 #endif
2546   HV* stash=NULL;
2547
2548   PERL_ARGS_ASSERT_AMAGIC_CALL;
2549
2550   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2551       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2552
2553       if ( !lex_mask || !SvOK(lex_mask) )
2554           /* overloading lexically disabled */
2555           return NULL;
2556       else if ( lex_mask && SvPOK(lex_mask) ) {
2557           /* we have an entry in the hints hash, check if method has been
2558            * masked by overloading.pm */
2559           STRLEN len;
2560           const int offset = method / 8;
2561           const int bit    = method % 8;
2562           char *pv = SvPV(lex_mask, len);
2563
2564           /* Bit set, so this overloading operator is disabled */
2565           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2566               return NULL;
2567       }
2568   }
2569
2570   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2571       && (stash = SvSTASH(SvRV(left)))
2572       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2573       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2574                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2575                         : NULL))
2576       && ((cv = cvp[off=method+assignshift])
2577           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2578                                                           * usual method */
2579                   (
2580 #ifdef DEBUGGING
2581                    fl = 1,
2582 #endif
2583                    cv = cvp[off=method])))) {
2584     lr = -1;                    /* Call method for left argument */
2585   } else {
2586     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2587       int logic;
2588
2589       /* look for substituted methods */
2590       /* In all the covered cases we should be called with assign==0. */
2591          switch (method) {
2592          case inc_amg:
2593            force_cpy = 1;
2594            if ((cv = cvp[off=add_ass_amg])
2595                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2596              right = &PL_sv_yes; lr = -1; assign = 1;
2597            }
2598            break;
2599          case dec_amg:
2600            force_cpy = 1;
2601            if ((cv = cvp[off = subtr_ass_amg])
2602                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2603              right = &PL_sv_yes; lr = -1; assign = 1;
2604            }
2605            break;
2606          case bool__amg:
2607            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2608            break;
2609          case numer_amg:
2610            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2611            break;
2612          case string_amg:
2613            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2614            break;
2615          case not_amg:
2616            (void)((cv = cvp[off=bool__amg])
2617                   || (cv = cvp[off=numer_amg])
2618                   || (cv = cvp[off=string_amg]));
2619            if (cv)
2620                postpr = 1;
2621            break;
2622          case copy_amg:
2623            {
2624              /*
2625                   * SV* ref causes confusion with the interpreter variable of
2626                   * the same name
2627                   */
2628              SV* const tmpRef=SvRV(left);
2629              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2630                 /*
2631                  * Just to be extra cautious.  Maybe in some
2632                  * additional cases sv_setsv is safe, too.
2633                  */
2634                 SV* const newref = newSVsv(tmpRef);
2635                 SvOBJECT_on(newref);
2636                 /* As a bit of a source compatibility hack, SvAMAGIC() and
2637                    friends dereference an RV, to behave the same was as when
2638                    overloading was stored on the reference, not the referant.
2639                    Hence we can't use SvAMAGIC_on()
2640                 */
2641                 SvFLAGS(newref) |= SVf_AMAGIC;
2642                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2643                 return newref;
2644              }
2645            }
2646            break;
2647          case abs_amg:
2648            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2649                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2650              SV* const nullsv=sv_2mortal(newSViv(0));
2651              if (off1==lt_amg) {
2652                SV* const lessp = amagic_call(left,nullsv,
2653                                        lt_amg,AMGf_noright);
2654                logic = SvTRUE(lessp);
2655              } else {
2656                SV* const lessp = amagic_call(left,nullsv,
2657                                        ncmp_amg,AMGf_noright);
2658                logic = (SvNV(lessp) < 0);
2659              }
2660              if (logic) {
2661                if (off==subtr_amg) {
2662                  right = left;
2663                  left = nullsv;
2664                  lr = 1;
2665                }
2666              } else {
2667                return left;
2668              }
2669            }
2670            break;
2671          case neg_amg:
2672            if ((cv = cvp[off=subtr_amg])) {
2673              right = left;
2674              left = sv_2mortal(newSViv(0));
2675              lr = 1;
2676            }
2677            break;
2678          case int_amg:
2679          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2680          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2681          case regexp_amg:
2682              /* FAIL safe */
2683              return NULL;       /* Delegate operation to standard mechanisms. */
2684              break;
2685          case to_sv_amg:
2686          case to_av_amg:
2687          case to_hv_amg:
2688          case to_gv_amg:
2689          case to_cv_amg:
2690              /* FAIL safe */
2691              return left;       /* Delegate operation to standard mechanisms. */
2692              break;
2693          default:
2694            goto not_found;
2695          }
2696          if (!cv) goto not_found;
2697     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2698                && (stash = SvSTASH(SvRV(right)))
2699                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2700                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2701                           ? (amtp = (AMT*)mg->mg_ptr)->table
2702                           : NULL))
2703                && (cv = cvp[off=method])) { /* Method for right
2704                                              * argument found */
2705       lr=1;
2706     } else if (((cvp && amtp->fallback > AMGfallNEVER)
2707                 || (ocvp && oamtp->fallback > AMGfallNEVER))
2708                && !(flags & AMGf_unary)) {
2709                                 /* We look for substitution for
2710                                  * comparison operations and
2711                                  * concatenation */
2712       if (method==concat_amg || method==concat_ass_amg
2713           || method==repeat_amg || method==repeat_ass_amg) {
2714         return NULL;            /* Delegate operation to string conversion */
2715       }
2716       off = -1;
2717       switch (method) {
2718          case lt_amg:
2719          case le_amg:
2720          case gt_amg:
2721          case ge_amg:
2722          case eq_amg:
2723          case ne_amg:
2724              off = ncmp_amg;
2725              break;
2726          case slt_amg:
2727          case sle_amg:
2728          case sgt_amg:
2729          case sge_amg:
2730          case seq_amg:
2731          case sne_amg:
2732              off = scmp_amg;
2733              break;
2734          }
2735       if (off != -1) {
2736           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2737               cv = ocvp[off];
2738               lr = -1;
2739           }
2740           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2741               cv = cvp[off];
2742               lr = 1;
2743           }
2744       }
2745       if (cv)
2746           postpr = 1;
2747       else
2748           goto not_found;
2749     } else {
2750     not_found:                  /* No method found, either report or croak */
2751       switch (method) {
2752          case to_sv_amg:
2753          case to_av_amg:
2754          case to_hv_amg:
2755          case to_gv_amg:
2756          case to_cv_amg:
2757              /* FAIL safe */
2758              return left;       /* Delegate operation to standard mechanisms. */
2759              break;
2760       }
2761       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2762         notfound = 1; lr = -1;
2763       } else if (cvp && (cv=cvp[nomethod_amg])) {
2764         notfound = 1; lr = 1;
2765       } else if ((use_default_op =
2766                   (!ocvp || oamtp->fallback >= AMGfallYES)
2767                   && (!cvp || amtp->fallback >= AMGfallYES))
2768                  && !DEBUG_o_TEST) {
2769         /* Skip generating the "no method found" message.  */
2770         return NULL;
2771       } else {
2772         SV *msg;
2773         if (off==-1) off=method;
2774         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2775                       "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2776                       AMG_id2name(method + assignshift),
2777                       (flags & AMGf_unary ? " " : "\n\tleft "),
2778                       SvAMAGIC(left)?
2779                         "in overloaded package ":
2780                         "has no overloaded magic",
2781                       SvAMAGIC(left)?
2782                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2783                         SVfARG(&PL_sv_no),
2784                       SvAMAGIC(right)?
2785                         ",\n\tright argument in overloaded package ":
2786                         (flags & AMGf_unary
2787                          ? ""
2788                          : ",\n\tright argument has no overloaded magic"),
2789                       SvAMAGIC(right)?
2790                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2791                         SVfARG(&PL_sv_no)));
2792         if (use_default_op) {
2793           DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
2794         } else {
2795           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2796         }
2797         return NULL;
2798       }
2799       force_cpy = force_cpy || assign;
2800     }
2801   }
2802 #ifdef DEBUGGING
2803   if (!notfound) {
2804     DEBUG_o(Perl_deb(aTHX_
2805                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
2806                      AMG_id2name(off),
2807                      method+assignshift==off? "" :
2808                      " (initially \"",
2809                      method+assignshift==off? "" :
2810                      AMG_id2name(method+assignshift),
2811                      method+assignshift==off? "" : "\")",
2812                      flags & AMGf_unary? "" :
2813                      lr==1 ? " for right argument": " for left argument",
2814                      flags & AMGf_unary? " for argument" : "",
2815                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
2816                      fl? ",\n\tassignment variant used": "") );
2817   }
2818 #endif
2819     /* Since we use shallow copy during assignment, we need
2820      * to dublicate the contents, probably calling user-supplied
2821      * version of copy operator
2822      */
2823     /* We need to copy in following cases:
2824      * a) Assignment form was called.
2825      *          assignshift==1,  assign==T, method + 1 == off
2826      * b) Increment or decrement, called directly.
2827      *          assignshift==0,  assign==0, method + 0 == off
2828      * c) Increment or decrement, translated to assignment add/subtr.
2829      *          assignshift==0,  assign==T,
2830      *          force_cpy == T
2831      * d) Increment or decrement, translated to nomethod.
2832      *          assignshift==0,  assign==0,
2833      *          force_cpy == T
2834      * e) Assignment form translated to nomethod.
2835      *          assignshift==1,  assign==T, method + 1 != off
2836      *          force_cpy == T
2837      */
2838     /*  off is method, method+assignshift, or a result of opcode substitution.
2839      *  In the latter case assignshift==0, so only notfound case is important.
2840      */
2841   if (( (method + assignshift == off)
2842         && (assign || (method == inc_amg) || (method == dec_amg)))
2843       || force_cpy)
2844   {
2845       /* newSVsv does not behave as advertised, so we copy missing
2846        * information by hand */
2847       SV *tmpRef = SvRV(left);
2848       SV *rv_copy;
2849       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2850           SvRV_set(left, rv_copy);
2851           SvSETMAGIC(left);
2852           SvREFCNT_dec(tmpRef);
2853       }
2854   }
2855
2856   {
2857     dSP;
2858     BINOP myop;
2859     SV* res;
2860     const bool oldcatch = CATCH_GET;
2861
2862     CATCH_SET(TRUE);
2863     Zero(&myop, 1, BINOP);
2864     myop.op_last = (OP *) &myop;
2865     myop.op_next = NULL;
2866     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2867
2868     PUSHSTACKi(PERLSI_OVERLOAD);
2869     ENTER;
2870     SAVEOP();
2871     PL_op = (OP *) &myop;
2872     if (PERLDB_SUB && PL_curstash != PL_debstash)
2873         PL_op->op_private |= OPpENTERSUB_DB;
2874     PUTBACK;
2875     Perl_pp_pushmark(aTHX);
2876
2877     EXTEND(SP, notfound + 5);
2878     PUSHs(lr>0? right: left);
2879     PUSHs(lr>0? left: right);
2880     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2881     if (notfound) {
2882       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2883                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2884     }
2885     PUSHs(MUTABLE_SV(cv));
2886     PUTBACK;
2887
2888     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2889       CALLRUNOPS(aTHX);
2890     LEAVE;
2891     SPAGAIN;
2892
2893     res=POPs;
2894     PUTBACK;
2895     POPSTACK;
2896     CATCH_SET(oldcatch);
2897
2898     if (postpr) {
2899       int ans;
2900       switch (method) {
2901       case le_amg:
2902       case sle_amg:
2903         ans=SvIV(res)<=0; break;
2904       case lt_amg:
2905       case slt_amg:
2906         ans=SvIV(res)<0; break;
2907       case ge_amg:
2908       case sge_amg:
2909         ans=SvIV(res)>=0; break;
2910       case gt_amg:
2911       case sgt_amg:
2912         ans=SvIV(res)>0; break;
2913       case eq_amg:
2914       case seq_amg:
2915         ans=SvIV(res)==0; break;
2916       case ne_amg:
2917       case sne_amg:
2918         ans=SvIV(res)!=0; break;
2919       case inc_amg:
2920       case dec_amg:
2921         SvSetSV(left,res); return left;
2922       case not_amg:
2923         ans=!SvTRUE(res); break;
2924       default:
2925         ans=0; break;
2926       }
2927       return boolSV(ans);
2928     } else if (method==copy_amg) {
2929       if (!SvROK(res)) {
2930         Perl_croak(aTHX_ "Copy method did not return a reference");
2931       }
2932       return SvREFCNT_inc(SvRV(res));
2933     } else {
2934       return res;
2935     }
2936   }
2937 }
2938
2939 void
2940 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2941 {
2942     dVAR;
2943     U32 hash;
2944
2945     PERL_ARGS_ASSERT_GV_NAME_SET;
2946
2947     if (len > I32_MAX)
2948         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2949
2950     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2951         unshare_hek(GvNAME_HEK(gv));
2952     }
2953
2954     PERL_HASH(hash, name, len);
2955     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2956 }
2957
2958 /*
2959 =for apidoc gv_try_downgrade
2960
2961 If the typeglob C<gv> can be expressed more succinctly, by having
2962 something other than a real GV in its place in the stash, replace it
2963 with the optimised form.  Basic requirements for this are that C<gv>
2964 is a real typeglob, is sufficiently ordinary, and is only referenced
2965 from its package.  This function is meant to be used when a GV has been
2966 looked up in part to see what was there, causing upgrading, but based
2967 on what was found it turns out that the real GV isn't required after all.
2968
2969 If C<gv> is a completely empty typeglob, it is deleted from the stash.
2970
2971 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2972 sub, the typeglob is replaced with a scalar-reference placeholder that
2973 more compactly represents the same thing.
2974
2975 =cut
2976 */
2977
2978 void
2979 Perl_gv_try_downgrade(pTHX_ GV *gv)
2980 {
2981     HV *stash;
2982     CV *cv;
2983     HEK *namehek;
2984     SV **gvp;
2985     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
2986
2987     /* XXX Why and where does this leave dangling pointers during global
2988        destruction? */
2989     if (PL_phase == PERL_PHASE_DESTRUCT) return;
2990
2991     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
2992             !SvOBJECT(gv) && !SvREADONLY(gv) &&
2993             isGV_with_GP(gv) && GvGP(gv) &&
2994             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
2995             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
2996             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2997         return;
2998     if (SvMAGICAL(gv)) {
2999         MAGIC *mg;
3000         /* only backref magic is allowed */
3001         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3002             return;
3003         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3004             if (mg->mg_type != PERL_MAGIC_backref)
3005                 return;
3006         }
3007     }
3008     cv = GvCV(gv);
3009     if (!cv) {
3010         HEK *gvnhek = GvNAME_HEK(gv);
3011         (void)hv_delete(stash, HEK_KEY(gvnhek),
3012             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3013     } else if (GvMULTI(gv) && cv &&
3014             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3015             CvSTASH(cv) == stash && CvGV(cv) == gv &&
3016             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3017             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3018             (namehek = GvNAME_HEK(gv)) &&
3019             (gvp = hv_fetch(stash, HEK_KEY(namehek),
3020                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3021             *gvp == (SV*)gv) {
3022         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3023         SvREFCNT(gv) = 0;
3024         sv_clear((SV*)gv);
3025         SvREFCNT(gv) = 1;
3026         SvFLAGS(gv) = SVt_IV|SVf_ROK;
3027         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3028                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3029         SvRV_set(gv, value);
3030     }
3031 }
3032
3033 #include "XSUB.h"
3034
3035 static void
3036 core_xsub(pTHX_ CV* cv)
3037 {
3038     Perl_croak(aTHX_
3039        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3040     );
3041 }
3042
3043 /*
3044  * Local variables:
3045  * c-indentation-style: bsd
3046  * c-basic-offset: 4
3047  * indent-tabs-mode: t
3048  * End:
3049  *
3050  * ex: set ts=8 sts=4 sw=4 noet:
3051  */