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