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