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_am == PL_amagic_generation
2247           && amtp->was_ok_sub == newgen) {
2248           return AMT_OVERLOADED(amtp) ? 1 : 0;
2249       }
2250       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2251   }
2252
2253   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2254
2255   Zero(&amt,1,AMT);
2256   amt.was_ok_am = PL_amagic_generation;
2257   amt.was_ok_sub = newgen;
2258   amt.fallback = AMGfallNO;
2259   amt.flags = 0;
2260
2261   {
2262     int filled = 0, have_ovl = 0;
2263     int i, lim = 1;
2264
2265     /* The first key in PL_AMG_names is the overloadedness indicator, which
2266        allows us to skip overloading entries for non-overloaded classes. */
2267
2268     /* Try to find via inheritance. */
2269     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2270     CV* cv;
2271
2272     if (!gv)
2273         lim = DESTROY_amg;              /* Skip overloading entries. */
2274
2275     else {
2276
2277       /* The "fallback" key is special-cased here, being absent from the
2278          list in PL_AMG_names. */
2279
2280       SV *sv;
2281       gv = gv_fetchmeth_pvn(stash, "(fallback", 9, -1, 0);
2282
2283       if (!gv || !(sv = GvSV(gv)))
2284         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2285       else if (SvTRUE(sv))
2286         amt.fallback=AMGfallYES;
2287       else if (SvOK(sv))
2288         amt.fallback=AMGfallNEVER;
2289     }
2290
2291     for (i = 1; i < lim; i++)
2292         amt.table[i] = NULL;
2293     for (; i < NofAMmeth; i++) {
2294         const char * const cooky = PL_AMG_names[i];
2295         /* Human-readable form, for debugging: */
2296         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2297         const STRLEN l = PL_AMG_namelens[i];
2298
2299         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2300                      cp, HvNAME_get(stash)) );
2301         /* don't fill the cache while looking up!
2302            Creation of inheritance stubs in intermediate packages may
2303            conflict with the logic of runtime method substitution.
2304            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2305            then we could have created stubs for "(+0" in A and C too.
2306            But if B overloads "bool", we may want to use it for
2307            numifying instead of C's "+0". */
2308         if (i >= DESTROY_amg)
2309             gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
2310         else                            /* Autoload taken care of below */
2311             gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2312         cv = 0;
2313         if (gv && (cv = GvCV(gv))) {
2314             if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2315               const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2316               if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2317                && strEQ(hvname, "overload")) {
2318                 /* This is a hack to support autoloading..., while
2319                    knowing *which* methods were declared as overloaded. */
2320                 /* GvSV contains the name of the method. */
2321                 GV *ngv = NULL;
2322                 SV *gvsv = GvSV(gv);
2323
2324                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2325                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2326                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2327                 if (!gvsv || !SvPOK(gvsv)
2328                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2329                 {
2330                     /* Can be an import stub (created by "can"). */
2331                     if (destructing) {
2332                         return -1;
2333                     }
2334                     else {
2335                         const SV * const name = (gvsv && SvPOK(gvsv))
2336                                                     ? gvsv
2337                                                     : newSVpvs_flags("???", SVs_TEMP);
2338                         /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2339                         Perl_croak(aTHX_ "%s method \"%"SVf256
2340                                     "\" overloading \"%s\" "\
2341                                     "in package \"%"HEKf256"\"",
2342                                    (GvCVGEN(gv) ? "Stub found while resolving"
2343                                     : "Can't resolve"),
2344                                    SVfARG(name), cp,
2345                                    HEKfARG(
2346                                         HvNAME_HEK(stash)
2347                                    ));
2348                     }
2349                 }
2350                 cv = GvCV(gv = ngv);
2351               }
2352             }
2353             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2354                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2355                          GvNAME(CvGV(cv))) );
2356             filled = 1;
2357             if (i < DESTROY_amg)
2358                 have_ovl = 1;
2359         } else if (gv) {                /* Autoloaded... */
2360             cv = MUTABLE_CV(gv);
2361             filled = 1;
2362         }
2363         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2364     }
2365     if (filled) {
2366       AMT_AMAGIC_on(&amt);
2367       if (have_ovl)
2368           AMT_OVERLOADED_on(&amt);
2369       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2370                                                 (char*)&amt, sizeof(AMT));
2371       return have_ovl;
2372     }
2373   }
2374   /* Here we have no table: */
2375   /* no_table: */
2376   AMT_AMAGIC_off(&amt);
2377   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2378                                                 (char*)&amt, sizeof(AMTS));
2379   return 0;
2380 }
2381
2382
2383 CV*
2384 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2385 {
2386     dVAR;
2387     MAGIC *mg;
2388     AMT *amtp;
2389     U32 newgen;
2390     struct mro_meta* stash_meta;
2391
2392     if (!stash || !HvNAME_get(stash))
2393         return NULL;
2394
2395     stash_meta = HvMROMETA(stash);
2396     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2397
2398     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2399     if (!mg) {
2400       do_update:
2401         /* If we're looking up a destructor to invoke, we must avoid
2402          * that Gv_AMupdate croaks, because we might be dying already */
2403         if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2404             /* and if it didn't found a destructor, we fall back
2405              * to a simpler method that will only look for the
2406              * destructor instead of the whole magic */
2407             if (id == DESTROY_amg) {
2408                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2409                 if (gv)
2410                     return GvCV(gv);
2411             }
2412             return NULL;
2413         }
2414         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2415     }
2416     assert(mg);
2417     amtp = (AMT*)mg->mg_ptr;
2418     if ( amtp->was_ok_am != PL_amagic_generation
2419          || amtp->was_ok_sub != newgen )
2420         goto do_update;
2421     if (AMT_AMAGIC(amtp)) {
2422         CV * const ret = amtp->table[id];
2423         if (ret && isGV(ret)) {         /* Autoloading stab */
2424             /* Passing it through may have resulted in a warning
2425                "Inherited AUTOLOAD for a non-method deprecated", since
2426                our caller is going through a function call, not a method call.
2427                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2428             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2429
2430             if (gv && GvCV(gv))
2431                 return GvCV(gv);
2432         }
2433         return ret;
2434     }
2435
2436     return NULL;
2437 }
2438
2439
2440 /* Implement tryAMAGICun_MG macro.
2441    Do get magic, then see if the stack arg is overloaded and if so call it.
2442    Flags:
2443         AMGf_set     return the arg using SETs rather than assigning to
2444                      the targ
2445         AMGf_numeric apply sv_2num to the stack arg.
2446 */
2447
2448 bool
2449 Perl_try_amagic_un(pTHX_ int method, int flags) {
2450     dVAR;
2451     dSP;
2452     SV* tmpsv;
2453     SV* const arg = TOPs;
2454
2455     SvGETMAGIC(arg);
2456
2457     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2458                                               AMGf_noright | AMGf_unary))) {
2459         if (flags & AMGf_set) {
2460             SETs(tmpsv);
2461         }
2462         else {
2463             dTARGET;
2464             if (SvPADMY(TARG)) {
2465                 sv_setsv(TARG, tmpsv);
2466                 SETTARG;
2467             }
2468             else
2469                 SETs(tmpsv);
2470         }
2471         PUTBACK;
2472         return TRUE;
2473     }
2474
2475     if ((flags & AMGf_numeric) && SvROK(arg))
2476         *sp = sv_2num(arg);
2477     return FALSE;
2478 }
2479
2480
2481 /* Implement tryAMAGICbin_MG macro.
2482    Do get magic, then see if the two stack args are overloaded and if so
2483    call it.
2484    Flags:
2485         AMGf_set     return the arg using SETs rather than assigning to
2486                      the targ
2487         AMGf_assign  op may be called as mutator (eg +=)
2488         AMGf_numeric apply sv_2num to the stack arg.
2489 */
2490
2491 bool
2492 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2493     dVAR;
2494     dSP;
2495     SV* const left = TOPm1s;
2496     SV* const right = TOPs;
2497
2498     SvGETMAGIC(left);
2499     if (left != right)
2500         SvGETMAGIC(right);
2501
2502     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2503         SV * const tmpsv = amagic_call(left, right, method,
2504                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2505         if (tmpsv) {
2506             if (flags & AMGf_set) {
2507                 (void)POPs;
2508                 SETs(tmpsv);
2509             }
2510             else {
2511                 dATARGET;
2512                 (void)POPs;
2513                 if (opASSIGN || SvPADMY(TARG)) {
2514                     sv_setsv(TARG, tmpsv);
2515                     SETTARG;
2516                 }
2517                 else
2518                     SETs(tmpsv);
2519             }
2520             PUTBACK;
2521             return TRUE;
2522         }
2523     }
2524     if(left==right && SvGMAGICAL(left)) {
2525         SV * const left = sv_newmortal();
2526         *(sp-1) = left;
2527         /* Print the uninitialized warning now, so it includes the vari-
2528            able name. */
2529         if (!SvOK(right)) {
2530             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2531             sv_setsv_flags(left, &PL_sv_no, 0);
2532         }
2533         else sv_setsv_flags(left, right, 0);
2534         SvGETMAGIC(right);
2535     }
2536     if (flags & AMGf_numeric) {
2537         if (SvROK(TOPm1s))
2538             *(sp-1) = sv_2num(TOPm1s);
2539         if (SvROK(right))
2540             *sp     = sv_2num(right);
2541     }
2542     return FALSE;
2543 }
2544
2545 SV *
2546 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2547     SV *tmpsv = NULL;
2548
2549     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2550
2551     while (SvAMAGIC(ref) &&
2552            (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2553                                 AMGf_noright | AMGf_unary))) {
2554         if (!SvROK(tmpsv))
2555             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2556         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2557             /* Bail out if it returns us the same reference.  */
2558             return tmpsv;
2559         }
2560         ref = tmpsv;
2561     }
2562     return tmpsv ? tmpsv : ref;
2563 }
2564
2565 bool
2566 Perl_amagic_is_enabled(pTHX_ int method)
2567 {
2568       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2569
2570       assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2571
2572       if ( !lex_mask || !SvOK(lex_mask) )
2573           /* overloading lexically disabled */
2574           return FALSE;
2575       else if ( lex_mask && SvPOK(lex_mask) ) {
2576           /* we have an entry in the hints hash, check if method has been
2577            * masked by overloading.pm */
2578           STRLEN len;
2579           const int offset = method / 8;
2580           const int bit    = method % 8;
2581           char *pv = SvPV(lex_mask, len);
2582
2583           /* Bit set, so this overloading operator is disabled */
2584           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2585               return FALSE;
2586       }
2587       return TRUE;
2588 }
2589
2590 SV*
2591 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2592 {
2593   dVAR;
2594   MAGIC *mg;
2595   CV *cv=NULL;
2596   CV **cvp=NULL, **ocvp=NULL;
2597   AMT *amtp=NULL, *oamtp=NULL;
2598   int off = 0, off1, lr = 0, notfound = 0;
2599   int postpr = 0, force_cpy = 0;
2600   int assign = AMGf_assign & flags;
2601   const int assignshift = assign ? 1 : 0;
2602   int use_default_op = 0;
2603 #ifdef DEBUGGING
2604   int fl=0;
2605 #endif
2606   HV* stash=NULL;
2607
2608   PERL_ARGS_ASSERT_AMAGIC_CALL;
2609
2610   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2611       if (!amagic_is_enabled(method)) return NULL;
2612   }
2613
2614   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2615       && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
2616       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2617       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2618                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2619                         : NULL))
2620       && ((cv = cvp[off=method+assignshift])
2621           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2622                                                           * usual method */
2623                   (
2624 #ifdef DEBUGGING
2625                    fl = 1,
2626 #endif
2627                    cv = cvp[off=method])))) {
2628     lr = -1;                    /* Call method for left argument */
2629   } else {
2630     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2631       int logic;
2632
2633       /* look for substituted methods */
2634       /* In all the covered cases we should be called with assign==0. */
2635          switch (method) {
2636          case inc_amg:
2637            force_cpy = 1;
2638            if ((cv = cvp[off=add_ass_amg])
2639                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2640              right = &PL_sv_yes; lr = -1; assign = 1;
2641            }
2642            break;
2643          case dec_amg:
2644            force_cpy = 1;
2645            if ((cv = cvp[off = subtr_ass_amg])
2646                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2647              right = &PL_sv_yes; lr = -1; assign = 1;
2648            }
2649            break;
2650          case bool__amg:
2651            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2652            break;
2653          case numer_amg:
2654            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2655            break;
2656          case string_amg:
2657            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2658            break;
2659          case not_amg:
2660            (void)((cv = cvp[off=bool__amg])
2661                   || (cv = cvp[off=numer_amg])
2662                   || (cv = cvp[off=string_amg]));
2663            if (cv)
2664                postpr = 1;
2665            break;
2666          case copy_amg:
2667            {
2668              /*
2669                   * SV* ref causes confusion with the interpreter variable of
2670                   * the same name
2671                   */
2672              SV* const tmpRef=SvRV(left);
2673              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2674                 /*
2675                  * Just to be extra cautious.  Maybe in some
2676                  * additional cases sv_setsv is safe, too.
2677                  */
2678                 SV* const newref = newSVsv(tmpRef);
2679                 SvOBJECT_on(newref);
2680                 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2681                    delegate to the stash. */
2682                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2683                 return newref;
2684              }
2685            }
2686            break;
2687          case abs_amg:
2688            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2689                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2690              SV* const nullsv=sv_2mortal(newSViv(0));
2691              if (off1==lt_amg) {
2692                SV* const lessp = amagic_call(left,nullsv,
2693                                        lt_amg,AMGf_noright);
2694                logic = SvTRUE(lessp);
2695              } else {
2696                SV* const lessp = amagic_call(left,nullsv,
2697                                        ncmp_amg,AMGf_noright);
2698                logic = (SvNV(lessp) < 0);
2699              }
2700              if (logic) {
2701                if (off==subtr_amg) {
2702                  right = left;
2703                  left = nullsv;
2704                  lr = 1;
2705                }
2706              } else {
2707                return left;
2708              }
2709            }
2710            break;
2711          case neg_amg:
2712            if ((cv = cvp[off=subtr_amg])) {
2713              right = left;
2714              left = sv_2mortal(newSViv(0));
2715              lr = 1;
2716            }
2717            break;
2718          case int_amg:
2719          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2720          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2721          case regexp_amg:
2722              /* FAIL safe */
2723              return NULL;       /* Delegate operation to standard mechanisms. */
2724              break;
2725          case to_sv_amg:
2726          case to_av_amg:
2727          case to_hv_amg:
2728          case to_gv_amg:
2729          case to_cv_amg:
2730              /* FAIL safe */
2731              return left;       /* Delegate operation to standard mechanisms. */
2732              break;
2733          default:
2734            goto not_found;
2735          }
2736          if (!cv) goto not_found;
2737     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2738                && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
2739                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2740                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2741                           ? (amtp = (AMT*)mg->mg_ptr)->table
2742                           : NULL))
2743                && ((cv = cvp[off=method+assignshift])
2744                    || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2745                                                                    * usual method */
2746                        (
2747 #ifdef DEBUGGING
2748                         fl = 1,
2749 #endif
2750                         cv = cvp[off=method])))) { /* Method for right
2751                                                     * argument found */
2752         lr=1;
2753     } else if (((cvp && amtp->fallback > AMGfallNEVER)
2754                 || (ocvp && oamtp->fallback > AMGfallNEVER))
2755                && !(flags & AMGf_unary)) {
2756                                 /* We look for substitution for
2757                                  * comparison operations and
2758                                  * concatenation */
2759       if (method==concat_amg || method==concat_ass_amg
2760           || method==repeat_amg || method==repeat_ass_amg) {
2761         return NULL;            /* Delegate operation to string conversion */
2762       }
2763       off = -1;
2764       switch (method) {
2765          case lt_amg:
2766          case le_amg:
2767          case gt_amg:
2768          case ge_amg:
2769          case eq_amg:
2770          case ne_amg:
2771              off = ncmp_amg;
2772              break;
2773          case slt_amg:
2774          case sle_amg:
2775          case sgt_amg:
2776          case sge_amg:
2777          case seq_amg:
2778          case sne_amg:
2779              off = scmp_amg;
2780              break;
2781          }
2782       if (off != -1) {
2783           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2784               cv = ocvp[off];
2785               lr = -1;
2786           }
2787           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2788               cv = cvp[off];
2789               lr = 1;
2790           }
2791       }
2792       if (cv)
2793           postpr = 1;
2794       else
2795           goto not_found;
2796     } else {
2797     not_found:                  /* No method found, either report or croak */
2798       switch (method) {
2799          case to_sv_amg:
2800          case to_av_amg:
2801          case to_hv_amg:
2802          case to_gv_amg:
2803          case to_cv_amg:
2804              /* FAIL safe */
2805              return left;       /* Delegate operation to standard mechanisms. */
2806              break;
2807       }
2808       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2809         notfound = 1; lr = -1;
2810       } else if (cvp && (cv=cvp[nomethod_amg])) {
2811         notfound = 1; lr = 1;
2812       } else if ((use_default_op =
2813                   (!ocvp || oamtp->fallback >= AMGfallYES)
2814                   && (!cvp || amtp->fallback >= AMGfallYES))
2815                  && !DEBUG_o_TEST) {
2816         /* Skip generating the "no method found" message.  */
2817         return NULL;
2818       } else {
2819         SV *msg;
2820         if (off==-1) off=method;
2821         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2822                       "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2823                       AMG_id2name(method + assignshift),
2824                       (flags & AMGf_unary ? " " : "\n\tleft "),
2825                       SvAMAGIC(left)?
2826                         "in overloaded package ":
2827                         "has no overloaded magic",
2828                       SvAMAGIC(left)?
2829                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2830                         SVfARG(&PL_sv_no),
2831                       SvAMAGIC(right)?
2832                         ",\n\tright argument in overloaded package ":
2833                         (flags & AMGf_unary
2834                          ? ""
2835                          : ",\n\tright argument has no overloaded magic"),
2836                       SvAMAGIC(right)?
2837                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2838                         SVfARG(&PL_sv_no)));
2839         if (use_default_op) {
2840           DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
2841         } else {
2842           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2843         }
2844         return NULL;
2845       }
2846       force_cpy = force_cpy || assign;
2847     }
2848   }
2849 #ifdef DEBUGGING
2850   if (!notfound) {
2851     DEBUG_o(Perl_deb(aTHX_
2852                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
2853                      AMG_id2name(off),
2854                      method+assignshift==off? "" :
2855                      " (initially \"",
2856                      method+assignshift==off? "" :
2857                      AMG_id2name(method+assignshift),
2858                      method+assignshift==off? "" : "\")",
2859                      flags & AMGf_unary? "" :
2860                      lr==1 ? " for right argument": " for left argument",
2861                      flags & AMGf_unary? " for argument" : "",
2862                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
2863                      fl? ",\n\tassignment variant used": "") );
2864   }
2865 #endif
2866     /* Since we use shallow copy during assignment, we need
2867      * to dublicate the contents, probably calling user-supplied
2868      * version of copy operator
2869      */
2870     /* We need to copy in following cases:
2871      * a) Assignment form was called.
2872      *          assignshift==1,  assign==T, method + 1 == off
2873      * b) Increment or decrement, called directly.
2874      *          assignshift==0,  assign==0, method + 0 == off
2875      * c) Increment or decrement, translated to assignment add/subtr.
2876      *          assignshift==0,  assign==T,
2877      *          force_cpy == T
2878      * d) Increment or decrement, translated to nomethod.
2879      *          assignshift==0,  assign==0,
2880      *          force_cpy == T
2881      * e) Assignment form translated to nomethod.
2882      *          assignshift==1,  assign==T, method + 1 != off
2883      *          force_cpy == T
2884      */
2885     /*  off is method, method+assignshift, or a result of opcode substitution.
2886      *  In the latter case assignshift==0, so only notfound case is important.
2887      */
2888   if ( (lr == -1) && ( ( (method + assignshift == off)
2889         && (assign || (method == inc_amg) || (method == dec_amg)))
2890       || force_cpy) )
2891   {
2892       /* newSVsv does not behave as advertised, so we copy missing
2893        * information by hand */
2894       SV *tmpRef = SvRV(left);
2895       SV *rv_copy;
2896       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2897           SvRV_set(left, rv_copy);
2898           SvSETMAGIC(left);
2899           SvREFCNT_dec(tmpRef);
2900       }
2901   }
2902
2903   {
2904     dSP;
2905     BINOP myop;
2906     SV* res;
2907     const bool oldcatch = CATCH_GET;
2908
2909     CATCH_SET(TRUE);
2910     Zero(&myop, 1, BINOP);
2911     myop.op_last = (OP *) &myop;
2912     myop.op_next = NULL;
2913     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2914
2915     PUSHSTACKi(PERLSI_OVERLOAD);
2916     ENTER;
2917     SAVEOP();
2918     PL_op = (OP *) &myop;
2919     if (PERLDB_SUB && PL_curstash != PL_debstash)
2920         PL_op->op_private |= OPpENTERSUB_DB;
2921     PUTBACK;
2922     Perl_pp_pushmark(aTHX);
2923
2924     EXTEND(SP, notfound + 5);
2925     PUSHs(lr>0? right: left);
2926     PUSHs(lr>0? left: right);
2927     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2928     if (notfound) {
2929       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2930                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2931     }
2932     PUSHs(MUTABLE_SV(cv));
2933     PUTBACK;
2934
2935     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2936       CALLRUNOPS(aTHX);
2937     LEAVE;
2938     SPAGAIN;
2939
2940     res=POPs;
2941     PUTBACK;
2942     POPSTACK;
2943     CATCH_SET(oldcatch);
2944
2945     if (postpr) {
2946       int ans;
2947       switch (method) {
2948       case le_amg:
2949       case sle_amg:
2950         ans=SvIV(res)<=0; break;
2951       case lt_amg:
2952       case slt_amg:
2953         ans=SvIV(res)<0; break;
2954       case ge_amg:
2955       case sge_amg:
2956         ans=SvIV(res)>=0; break;
2957       case gt_amg:
2958       case sgt_amg:
2959         ans=SvIV(res)>0; break;
2960       case eq_amg:
2961       case seq_amg:
2962         ans=SvIV(res)==0; break;
2963       case ne_amg:
2964       case sne_amg:
2965         ans=SvIV(res)!=0; break;
2966       case inc_amg:
2967       case dec_amg:
2968         SvSetSV(left,res); return left;
2969       case not_amg:
2970         ans=!SvTRUE(res); break;
2971       default:
2972         ans=0; break;
2973       }
2974       return boolSV(ans);
2975     } else if (method==copy_amg) {
2976       if (!SvROK(res)) {
2977         Perl_croak(aTHX_ "Copy method did not return a reference");
2978       }
2979       return SvREFCNT_inc(SvRV(res));
2980     } else {
2981       return res;
2982     }
2983   }
2984 }
2985
2986 void
2987 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2988 {
2989     dVAR;
2990     U32 hash;
2991
2992     PERL_ARGS_ASSERT_GV_NAME_SET;
2993
2994     if (len > I32_MAX)
2995         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2996
2997     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2998         unshare_hek(GvNAME_HEK(gv));
2999     }
3000
3001     PERL_HASH(hash, name, len);
3002     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3003 }
3004
3005 /*
3006 =for apidoc gv_try_downgrade
3007
3008 If the typeglob C<gv> can be expressed more succinctly, by having
3009 something other than a real GV in its place in the stash, replace it
3010 with the optimised form.  Basic requirements for this are that C<gv>
3011 is a real typeglob, is sufficiently ordinary, and is only referenced
3012 from its package.  This function is meant to be used when a GV has been
3013 looked up in part to see what was there, causing upgrading, but based
3014 on what was found it turns out that the real GV isn't required after all.
3015
3016 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3017
3018 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3019 sub, the typeglob is replaced with a scalar-reference placeholder that
3020 more compactly represents the same thing.
3021
3022 =cut
3023 */
3024
3025 void
3026 Perl_gv_try_downgrade(pTHX_ GV *gv)
3027 {
3028     HV *stash;
3029     CV *cv;
3030     HEK *namehek;
3031     SV **gvp;
3032     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3033
3034     /* XXX Why and where does this leave dangling pointers during global
3035        destruction? */
3036     if (PL_phase == PERL_PHASE_DESTRUCT) return;
3037
3038     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3039             !SvOBJECT(gv) && !SvREADONLY(gv) &&
3040             isGV_with_GP(gv) && GvGP(gv) &&
3041             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3042             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3043             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3044         return;
3045     if (SvMAGICAL(gv)) {
3046         MAGIC *mg;
3047         /* only backref magic is allowed */
3048         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3049             return;
3050         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3051             if (mg->mg_type != PERL_MAGIC_backref)
3052                 return;
3053         }
3054     }
3055     cv = GvCV(gv);
3056     if (!cv) {
3057         HEK *gvnhek = GvNAME_HEK(gv);
3058         (void)hv_delete(stash, HEK_KEY(gvnhek),
3059             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3060     } else if (GvMULTI(gv) && cv &&
3061             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3062             CvSTASH(cv) == stash && CvGV(cv) == gv &&
3063             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3064             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3065             (namehek = GvNAME_HEK(gv)) &&
3066             (gvp = hv_fetch(stash, HEK_KEY(namehek),
3067                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3068             *gvp == (SV*)gv) {
3069         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3070         SvREFCNT(gv) = 0;
3071         sv_clear((SV*)gv);
3072         SvREFCNT(gv) = 1;
3073         SvFLAGS(gv) = SVt_IV|SVf_ROK;
3074         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3075                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3076         SvRV_set(gv, value);
3077     }
3078 }
3079
3080 #include "XSUB.h"
3081
3082 static void
3083 core_xsub(pTHX_ CV* cv)
3084 {
3085     Perl_croak(aTHX_
3086        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3087     );
3088 }
3089
3090 /*
3091  * Local variables:
3092  * c-indentation-style: bsd
3093  * c-basic-offset: 4
3094  * indent-tabs-mode: t
3095  * End:
3096  *
3097  * ex: set ts=8 sts=4 sw=4 noet:
3098  */