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