gv.c

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