gv.c

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