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