gv.c

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