gv.c

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