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