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