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, addmg = 0;
1259     /* From this point on, addmg means gv has not been inserted in the
1260        symtab yet. */
1261
1262     if (SvTYPE(gv) == SVt_PVGV) {
1263         if (add) {
1264             GvMULTI_on(gv);
1265             gv_init_sv(gv, sv_type);
1266             if (len == 1 && stash == PL_defstash
1267                 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1268                 if (*name == '!')
1269                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1270                 else if (*name == '-' || *name == '+')
1271                     require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1272             }
1273             else if (len == 3 && sv_type == SVt_PVAV
1274                   && strnEQ(name, "ISA", 3)
1275                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1276                 gv_magicalize_isa(gv);
1277         }
1278         return gv;
1279     } else if (no_init) {
1280         assert(!addmg);
1281         return gv;
1282     } else if (no_expand && SvROK(gv)) {
1283         assert(!addmg);
1284         return gv;
1285     }
1286
1287     /* Adding a new symbol.
1288        Unless of course there was already something non-GV here, in which case
1289        we want to behave as if there was always a GV here, containing some sort
1290        of subroutine.
1291        Otherwise we run the risk of creating things like GvIO, which can cause
1292        subtle bugs. eg the one that tripped up SQL::Translator  */
1293
1294     faking_it = SvOK(gv);
1295
1296     if (add & GV_ADDWARN)
1297         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1298     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1299
1300     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1301                                             : (PL_dowarn & G_WARN_ON ) ) )
1302         GvMULTI_on(gv) ;
1303
1304     /* set up magic where warranted */
1305     if (stash != PL_defstash) { /* not the main stash */
1306         /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
1307            and VERSION. All the others apply only to the main stash or to
1308            CORE (which is checked right after this). */
1309         if (len > 2) {
1310             const char * const name2 = name + 1;
1311             switch (*name) {
1312             case 'E':
1313                 if (strnEQ(name2, "XPORT", 5))
1314                     GvMULTI_on(gv);
1315                 break;
1316             case 'I':
1317                 if (strEQ(name2, "SA"))
1318                     gv_magicalize_isa(gv);
1319                 break;
1320             case 'O':
1321                 if (strEQ(name2, "VERLOAD"))
1322                     gv_magicalize_overload(gv);
1323                 break;
1324             case 'V':
1325                 if (strEQ(name2, "ERSION"))
1326                     GvMULTI_on(gv);
1327                 break;
1328             default:
1329                 goto try_core;
1330             }
1331             goto add_magical_gv;
1332         }
1333       try_core:
1334         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1335           /* Avoid null warning: */
1336           const char * const stashname = HvNAME(stash); assert(stashname);
1337           if (strnEQ(stashname, "CORE", 4)) {
1338             const int code = keyword(name, len, 1);
1339             static const char file[] = __FILE__;
1340             CV *cv, *oldcompcv;
1341             int opnum = 0;
1342             SV *opnumsv;
1343             bool ampable = TRUE; /* &{}-able */
1344             COP *oldcurcop;
1345             yy_parser *oldparser;
1346             I32 oldsavestack_ix;
1347
1348             if (code >= 0) goto add_magical_gv; /* not overridable */
1349             switch (-code) {
1350              /* no support for \&CORE::infix;
1351                 no support for funcs that take labels, as their parsing is
1352                 weird  */
1353             case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
1354             case KEY_eq: case KEY_ge:
1355             case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
1356             case KEY_or: case KEY_x: case KEY_xor:
1357                 goto add_magical_gv;
1358             case KEY_chdir:
1359             case KEY_chomp: case KEY_chop:
1360             case KEY_each: case KEY_eof: case KEY_exec:
1361             case KEY_keys:
1362             case KEY_lstat:
1363             case KEY_pop:
1364             case KEY_push:
1365             case KEY_shift:
1366             case KEY_splice:
1367             case KEY_stat:
1368             case KEY_system:
1369             case KEY_truncate: case KEY_unlink:
1370             case KEY_unshift:
1371             case KEY_values:
1372                 ampable = FALSE;
1373             }
1374             if (ampable) {
1375                 ENTER;
1376                 oldcurcop = PL_curcop;
1377                 oldparser = PL_parser;
1378                 lex_start(NULL, NULL, 0);
1379                 oldcompcv = PL_compcv;
1380                 PL_compcv = NULL; /* Prevent start_subparse from setting
1381                                      CvOUTSIDE. */
1382                 oldsavestack_ix = start_subparse(FALSE,0);
1383                 cv = PL_compcv;
1384             }
1385             else {
1386                 /* Avoid calling newXS, as it calls us, and things start to
1387                    get hairy. */
1388                 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
1389                 GvCV_set(gv,cv);
1390                 GvCVGEN(gv) = 0;
1391                 mro_method_changed_in(GvSTASH(gv));
1392                 CvISXSUB_on(cv);
1393                 CvXSUB(cv) = core_xsub;
1394             }
1395             CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
1396                                  from PL_curcop. */
1397             (void)gv_fetchfile(file);
1398             CvFILE(cv) = (char *)file;
1399             /* XXX This is inefficient, as doing things this order causes
1400                    a prototype check in newATTRSUB.  But we have to do
1401                    it this order as we need an op number before calling
1402                    new ATTRSUB. */
1403             (void)core_prototype((SV *)cv, name, code, &opnum);
1404             if (ampable) {
1405                 if (addmg) {
1406                     (void)hv_store(stash,name,len,(SV *)gv,0);
1407                     addmg = FALSE;
1408                 }
1409                 CvLVALUE_on(cv);
1410                 newATTRSUB(oldsavestack_ix,
1411                            newSVOP(
1412                                  OP_CONST, 0,
1413                                  newSVpvn_share(nambeg,full_len,0)
1414                            ),
1415                            NULL,NULL,
1416                            coresub_op(
1417                              opnum
1418                                ? newSVuv((UV)opnum)
1419                                : newSVpvn(name,len),
1420                              code, opnum
1421                            )
1422                 );
1423                 assert(GvCV(gv) == cv);
1424                 if (opnum != OP_VEC && opnum != OP_SUBSTR)
1425                     CvLVALUE_off(cv); /* Now *that* was a neat trick. */
1426                 LEAVE;
1427                 PL_parser = oldparser;
1428                 PL_curcop = oldcurcop;
1429                 PL_compcv = oldcompcv;
1430             }
1431             opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
1432             cv_set_call_checker(
1433                cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
1434             );
1435             SvREFCNT_dec(opnumsv);
1436           }
1437         }
1438     }
1439     else if (len > 1) {
1440 #ifndef EBCDIC
1441         if (*name > 'V' ) {
1442             NOOP;
1443             /* Nothing else to do.
1444                The compiler will probably turn the switch statement into a
1445                branch table. Make sure we avoid even that small overhead for
1446                the common case of lower case variable names.  */
1447         } else
1448 #endif
1449         {
1450             const char * const name2 = name + 1;
1451             switch (*name) {
1452             case 'A':
1453                 if (strEQ(name2, "RGV")) {
1454                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1455                 }
1456                 else if (strEQ(name2, "RGVOUT")) {
1457                     GvMULTI_on(gv);
1458                 }
1459                 break;
1460             case 'E':
1461                 if (strnEQ(name2, "XPORT", 5))
1462                     GvMULTI_on(gv);
1463                 break;
1464             case 'I':
1465                 if (strEQ(name2, "SA")) {
1466                     gv_magicalize_isa(gv);
1467                 }
1468                 break;
1469             case 'O':
1470                 if (strEQ(name2, "VERLOAD")) {
1471                     gv_magicalize_overload(gv);
1472                 }
1473                 break;
1474             case 'S':
1475                 if (strEQ(name2, "IG")) {
1476                     HV *hv;
1477                     I32 i;
1478                     if (!PL_psig_name) {
1479                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1480                         Newxz(PL_psig_pend, SIG_SIZE, int);
1481                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1482                     } else {
1483                         /* I think that the only way to get here is to re-use an
1484                            embedded perl interpreter, where the previous
1485                            use didn't clean up fully because
1486                            PL_perl_destruct_level was 0. I'm not sure that we
1487                            "support" that, in that I suspect in that scenario
1488                            there are sufficient other garbage values left in the
1489                            interpreter structure that something else will crash
1490                            before we get here. I suspect that this is one of
1491                            those "doctor, it hurts when I do this" bugs.  */
1492                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1493                         Zero(PL_psig_pend, SIG_SIZE, int);
1494                     }
1495                     GvMULTI_on(gv);
1496                     hv = GvHVn(gv);
1497                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1498                     for (i = 1; i < SIG_SIZE; i++) {
1499                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1500                         if (init)
1501                             sv_setsv(*init, &PL_sv_undef);
1502                     }
1503                 }
1504                 break;
1505             case 'V':
1506                 if (strEQ(name2, "ERSION"))
1507                     GvMULTI_on(gv);
1508                 break;
1509             case '\003':        /* $^CHILD_ERROR_NATIVE */
1510                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1511                     goto magicalize;
1512                 break;
1513             case '\005':        /* $^ENCODING */
1514                 if (strEQ(name2, "NCODING"))
1515                     goto magicalize;
1516                 break;
1517             case '\007':        /* $^GLOBAL_PHASE */
1518                 if (strEQ(name2, "LOBAL_PHASE"))
1519                     goto ro_magicalize;
1520                 break;
1521             case '\015':        /* $^MATCH */
1522                 if (strEQ(name2, "ATCH"))
1523                     goto magicalize;
1524             case '\017':        /* $^OPEN */
1525                 if (strEQ(name2, "PEN"))
1526                     goto magicalize;
1527                 break;
1528             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1529                 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1530                     goto magicalize;
1531                 break;
1532             case '\024':        /* ${^TAINT} */
1533                 if (strEQ(name2, "AINT"))
1534                     goto ro_magicalize;
1535                 break;
1536             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1537                 if (strEQ(name2, "NICODE"))
1538                     goto ro_magicalize;
1539                 if (strEQ(name2, "TF8LOCALE"))
1540                     goto ro_magicalize;
1541                 if (strEQ(name2, "TF8CACHE"))
1542                     goto magicalize;
1543                 break;
1544             case '\027':        /* $^WARNING_BITS */
1545                 if (strEQ(name2, "ARNING_BITS"))
1546                     goto magicalize;
1547                 break;
1548             case '1':
1549             case '2':
1550             case '3':
1551             case '4':
1552             case '5':
1553             case '6':
1554             case '7':
1555             case '8':
1556             case '9':
1557             {
1558                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1559                    this test  */
1560                 /* This snippet is taken from is_gv_magical */
1561                 const char *end = name + len;
1562                 while (--end > name) {
1563                     if (!isDIGIT(*end)) goto add_magical_gv;
1564                 }
1565                 goto magicalize;
1566             }
1567             }
1568         }
1569     } else {
1570         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1571            be case '\0' in this switch statement (ie a default case)  */
1572         switch (*name) {
1573         case '&':               /* $& */
1574         case '`':               /* $` */
1575         case '\'':              /* $' */
1576             if (
1577                 sv_type == SVt_PVAV ||
1578                 sv_type == SVt_PVHV ||
1579                 sv_type == SVt_PVCV ||
1580                 sv_type == SVt_PVFM ||
1581                 sv_type == SVt_PVIO
1582                 ) { break; }
1583             PL_sawampersand = TRUE;
1584             goto magicalize;
1585
1586         case ':':               /* $: */
1587             sv_setpv(GvSVn(gv),PL_chopset);
1588             goto magicalize;
1589
1590         case '?':               /* $? */
1591 #ifdef COMPLEX_STATUS
1592             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1593 #endif
1594             goto magicalize;
1595
1596         case '!':               /* $! */
1597             GvMULTI_on(gv);
1598             /* If %! has been used, automatically load Errno.pm. */
1599
1600             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1601
1602             /* magicalization must be done before require_tie_mod is called */
1603             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1604                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1605
1606             break;
1607         case '-':               /* $- */
1608         case '+':               /* $+ */
1609         GvMULTI_on(gv); /* no used once warnings here */
1610         {
1611             AV* const av = GvAVn(gv);
1612             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1613
1614             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1615             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1616             if (avc)
1617                 SvREADONLY_on(GvSVn(gv));
1618             SvREADONLY_on(av);
1619
1620             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1621                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1622
1623             break;
1624         }
1625         case '*':               /* $* */
1626         case '#':               /* $# */
1627             if (sv_type == SVt_PV)
1628                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1629                                  "$%c is no longer supported", *name);
1630             break;
1631         case '|':               /* $| */
1632             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1633             goto magicalize;
1634
1635         case '\010':    /* $^H */
1636             {
1637                 HV *const hv = GvHVn(gv);
1638                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1639             }
1640             goto magicalize;
1641         case '\023':    /* $^S */
1642         ro_magicalize:
1643             SvREADONLY_on(GvSVn(gv));
1644             /* FALL THROUGH */
1645         case '0':               /* $0 */
1646         case '1':               /* $1 */
1647         case '2':               /* $2 */
1648         case '3':               /* $3 */
1649         case '4':               /* $4 */
1650         case '5':               /* $5 */
1651         case '6':               /* $6 */
1652         case '7':               /* $7 */
1653         case '8':               /* $8 */
1654         case '9':               /* $9 */
1655         case '[':               /* $[ */
1656         case '^':               /* $^ */
1657         case '~':               /* $~ */
1658         case '=':               /* $= */
1659         case '%':               /* $% */
1660         case '.':               /* $. */
1661         case '(':               /* $( */
1662         case ')':               /* $) */
1663         case '<':               /* $< */
1664         case '>':               /* $> */
1665         case '\\':              /* $\ */
1666         case '/':               /* $/ */
1667         case '$':               /* $$ */
1668         case '\001':    /* $^A */
1669         case '\003':    /* $^C */
1670         case '\004':    /* $^D */
1671         case '\005':    /* $^E */
1672         case '\006':    /* $^F */
1673         case '\011':    /* $^I, NOT \t in EBCDIC */
1674         case '\016':    /* $^N */
1675         case '\017':    /* $^O */
1676         case '\020':    /* $^P */
1677         case '\024':    /* $^T */
1678         case '\027':    /* $^W */
1679         magicalize:
1680             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1681             break;
1682
1683         case '\014':    /* $^L */
1684             sv_setpvs(GvSVn(gv),"\f");
1685             PL_formfeed = GvSVn(gv);
1686             break;
1687         case ';':               /* $; */
1688             sv_setpvs(GvSVn(gv),"\034");
1689             break;
1690         case ']':               /* $] */
1691         {
1692             SV * const sv = GvSV(gv);
1693             if (!sv_derived_from(PL_patchlevel, "version"))
1694                 upg_version(PL_patchlevel, TRUE);
1695             GvSV(gv) = vnumify(PL_patchlevel);
1696             SvREADONLY_on(GvSV(gv));
1697             SvREFCNT_dec(sv);
1698         }
1699         break;
1700         case '\026':    /* $^V */
1701         {
1702             SV * const sv = GvSV(gv);
1703             GvSV(gv) = new_version(PL_patchlevel);
1704             SvREADONLY_on(GvSV(gv));
1705             SvREFCNT_dec(sv);
1706         }
1707         break;
1708         }
1709     }
1710   add_magical_gv:
1711     if (addmg) {
1712         if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
1713              GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
1714            ))
1715             (void)hv_store(stash,name,len,(SV *)gv,0);
1716         else SvREFCNT_dec(gv), gv = NULL;
1717     }
1718     if (gv) gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
1719     return gv;
1720 }
1721
1722 void
1723 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1724 {
1725     const char *name;
1726     STRLEN namelen;
1727     const HV * const hv = GvSTASH(gv);
1728
1729     PERL_ARGS_ASSERT_GV_FULLNAME4;
1730
1731     if (!hv) {
1732         SvOK_off(sv);
1733         return;
1734     }
1735     sv_setpv(sv, prefix ? prefix : "");
1736
1737     name = HvNAME_get(hv);
1738     if (name) {
1739         namelen = HvNAMELEN_get(hv);
1740     } else {
1741         name = "__ANON__";
1742         namelen = 8;
1743     }
1744
1745     if (keepmain || strNE(name, "main")) {
1746         sv_catpvn(sv,name,namelen);
1747         sv_catpvs(sv,"::");
1748     }
1749     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1750 }
1751
1752 void
1753 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1754 {
1755     const GV * const egv = GvEGVx(gv);
1756
1757     PERL_ARGS_ASSERT_GV_EFULLNAME4;
1758
1759     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1760 }
1761
1762 void
1763 Perl_gv_check(pTHX_ const HV *stash)
1764 {
1765     dVAR;
1766     register I32 i;
1767
1768     PERL_ARGS_ASSERT_GV_CHECK;
1769
1770     if (!HvARRAY(stash))
1771         return;
1772     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1773         const HE *entry;
1774         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1775             register GV *gv;
1776             HV *hv;
1777             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1778                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
1779             {
1780                 if (hv != PL_defstash && hv != stash)
1781                      gv_check(hv);              /* nested package */
1782             }
1783             else if (isALPHA(*HeKEY(entry))) {
1784                 const char *file;
1785                 gv = MUTABLE_GV(HeVAL(entry));
1786                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1787                     continue;
1788                 file = GvFILE(gv);
1789                 CopLINE_set(PL_curcop, GvLINE(gv));
1790 #ifdef USE_ITHREADS
1791                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1792 #else
1793                 CopFILEGV(PL_curcop)
1794                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1795 #endif
1796                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1797                         "Name \"%s::%s\" used only once: possible typo",
1798                         HvNAME_get(stash), GvNAME(gv));
1799             }
1800         }
1801     }
1802 }
1803
1804 GV *
1805 Perl_newGVgen(pTHX_ const char *pack)
1806 {
1807     dVAR;
1808
1809     PERL_ARGS_ASSERT_NEWGVGEN;
1810
1811     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1812                       GV_ADD, SVt_PVGV);
1813 }
1814
1815 /* hopefully this is only called on local symbol table entries */
1816
1817 GP*
1818 Perl_gp_ref(pTHX_ GP *gp)
1819 {
1820     dVAR;
1821     if (!gp)
1822         return NULL;
1823     gp->gp_refcnt++;
1824     if (gp->gp_cv) {
1825         if (gp->gp_cvgen) {
1826             /* If the GP they asked for a reference to contains
1827                a method cache entry, clear it first, so that we
1828                don't infect them with our cached entry */
1829             SvREFCNT_dec(gp->gp_cv);
1830             gp->gp_cv = NULL;
1831             gp->gp_cvgen = 0;
1832         }
1833     }
1834     return gp;
1835 }
1836
1837 void
1838 Perl_gp_free(pTHX_ GV *gv)
1839 {
1840     dVAR;
1841     GP* gp;
1842     int attempts = 100;
1843
1844     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1845         return;
1846     if (gp->gp_refcnt == 0) {
1847         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1848                          "Attempt to free unreferenced glob pointers"
1849                          pTHX__FORMAT pTHX__VALUE);
1850         return;
1851     }
1852     if (--gp->gp_refcnt > 0) {
1853         if (gp->gp_egv == gv)
1854             gp->gp_egv = 0;
1855         GvGP_set(gv, NULL);
1856         return;
1857     }
1858
1859     while (1) {
1860       /* Copy and null out all the glob slots, so destructors do not see
1861          freed SVs. */
1862       HEK * const file_hek = gp->gp_file_hek;
1863       SV  * const sv       = gp->gp_sv;
1864       AV  * const av       = gp->gp_av;
1865       HV  * const hv       = gp->gp_hv;
1866       IO  * const io       = gp->gp_io;
1867       CV  * const cv       = gp->gp_cv;
1868       CV  * const form     = gp->gp_form;
1869
1870       gp->gp_file_hek = NULL;
1871       gp->gp_sv       = NULL;
1872       gp->gp_av       = NULL;
1873       gp->gp_hv       = NULL;
1874       gp->gp_io       = NULL;
1875       gp->gp_cv       = NULL;
1876       gp->gp_form     = NULL;
1877
1878       if (file_hek)
1879         unshare_hek(file_hek);
1880
1881       SvREFCNT_dec(sv);
1882       SvREFCNT_dec(av);
1883       /* FIXME - another reference loop GV -> symtab -> GV ?
1884          Somehow gp->gp_hv can end up pointing at freed garbage.  */
1885       if (hv && SvTYPE(hv) == SVt_PVHV) {
1886         const char *hvname = HvNAME_get(hv);
1887         if (PL_stashcache && hvname)
1888             (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
1889                       G_DISCARD);
1890         SvREFCNT_dec(hv);
1891       }
1892       SvREFCNT_dec(io);
1893       SvREFCNT_dec(cv);
1894       SvREFCNT_dec(form);
1895
1896       if (!gp->gp_file_hek
1897        && !gp->gp_sv
1898        && !gp->gp_av
1899        && !gp->gp_hv
1900        && !gp->gp_io
1901        && !gp->gp_cv
1902        && !gp->gp_form) break;
1903
1904       if (--attempts == 0) {
1905         Perl_die(aTHX_
1906           "panic: gp_free failed to free glob pointer - "
1907           "something is repeatedly re-creating entries"
1908         );
1909       }
1910     }
1911
1912     Safefree(gp);
1913     GvGP_set(gv, NULL);
1914 }
1915
1916 int
1917 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1918 {
1919     AMT * const amtp = (AMT*)mg->mg_ptr;
1920     PERL_UNUSED_ARG(sv);
1921
1922     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1923
1924     if (amtp && AMT_AMAGIC(amtp)) {
1925         int i;
1926         for (i = 1; i < NofAMmeth; i++) {
1927             CV * const cv = amtp->table[i];
1928             if (cv) {
1929                 SvREFCNT_dec(MUTABLE_SV(cv));
1930                 amtp->table[i] = NULL;
1931             }
1932         }
1933     }
1934  return 0;
1935 }
1936
1937 /* Updates and caches the CV's */
1938 /* Returns:
1939  * 1 on success and there is some overload
1940  * 0 if there is no overload
1941  * -1 if some error occurred and it couldn't croak
1942  */
1943
1944 int
1945 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
1946 {
1947   dVAR;
1948   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1949   AMT amt;
1950   const struct mro_meta* stash_meta = HvMROMETA(stash);
1951   U32 newgen;
1952
1953   PERL_ARGS_ASSERT_GV_AMUPDATE;
1954
1955   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1956   if (mg) {
1957       const AMT * const amtp = (AMT*)mg->mg_ptr;
1958       if (amtp->was_ok_am == PL_amagic_generation
1959           && amtp->was_ok_sub == newgen) {
1960           return AMT_OVERLOADED(amtp) ? 1 : 0;
1961       }
1962       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
1963   }
1964
1965   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1966
1967   Zero(&amt,1,AMT);
1968   amt.was_ok_am = PL_amagic_generation;
1969   amt.was_ok_sub = newgen;
1970   amt.fallback = AMGfallNO;
1971   amt.flags = 0;
1972
1973   {
1974     int filled = 0, have_ovl = 0;
1975     int i, lim = 1;
1976
1977     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1978
1979     /* Try to find via inheritance. */
1980     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1981     SV * const sv = gv ? GvSV(gv) : NULL;
1982     CV* cv;
1983
1984     if (!gv)
1985         lim = DESTROY_amg;              /* Skip overloading entries. */
1986 #ifdef PERL_DONT_CREATE_GVSV
1987     else if (!sv) {
1988         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1989     }
1990 #endif
1991     else if (SvTRUE(sv))
1992         amt.fallback=AMGfallYES;
1993     else if (SvOK(sv))
1994         amt.fallback=AMGfallNEVER;
1995
1996     for (i = 1; i < lim; i++)
1997         amt.table[i] = NULL;
1998     for (; i < NofAMmeth; i++) {
1999         const char * const cooky = PL_AMG_names[i];
2000         /* Human-readable form, for debugging: */
2001         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2002         const STRLEN l = PL_AMG_namelens[i];
2003
2004         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2005                      cp, HvNAME_get(stash)) );
2006         /* don't fill the cache while looking up!
2007            Creation of inheritance stubs in intermediate packages may
2008            conflict with the logic of runtime method substitution.
2009            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2010            then we could have created stubs for "(+0" in A and C too.
2011            But if B overloads "bool", we may want to use it for
2012            numifying instead of C's "+0". */
2013         if (i >= DESTROY_amg)
2014             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
2015         else                            /* Autoload taken care of below */
2016             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
2017         cv = 0;
2018         if (gv && (cv = GvCV(gv))) {
2019             const char *hvname;
2020             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
2021                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
2022                 /* This is a hack to support autoloading..., while
2023                    knowing *which* methods were declared as overloaded. */
2024                 /* GvSV contains the name of the method. */
2025                 GV *ngv = NULL;
2026                 SV *gvsv = GvSV(gv);
2027
2028                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2029                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2030                              (void*)GvSV(gv), cp, hvname) );
2031                 if (!gvsv || !SvPOK(gvsv)
2032                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
2033                                                        FALSE)))
2034                 {
2035                     /* Can be an import stub (created by "can"). */
2036                     if (destructing) {
2037                         return -1;
2038                     }
2039                     else {
2040                         const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
2041                         Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
2042                                     "in package \"%.256s\"",
2043                                    (GvCVGEN(gv) ? "Stub found while resolving"
2044                                     : "Can't resolve"),
2045                                    name, cp, hvname);
2046                     }
2047                 }
2048                 cv = GvCV(gv = ngv);
2049             }
2050             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2051                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2052                          GvNAME(CvGV(cv))) );
2053             filled = 1;
2054             if (i < DESTROY_amg)
2055                 have_ovl = 1;
2056         } else if (gv) {                /* Autoloaded... */
2057             cv = MUTABLE_CV(gv);
2058             filled = 1;
2059         }
2060         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2061     }
2062     if (filled) {
2063       AMT_AMAGIC_on(&amt);
2064       if (have_ovl)
2065           AMT_OVERLOADED_on(&amt);
2066       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2067                                                 (char*)&amt, sizeof(AMT));
2068       return have_ovl;
2069     }
2070   }
2071   /* Here we have no table: */
2072   /* no_table: */
2073   AMT_AMAGIC_off(&amt);
2074   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2075                                                 (char*)&amt, sizeof(AMTS));
2076   return 0;
2077 }
2078
2079
2080 CV*
2081 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2082 {
2083     dVAR;
2084     MAGIC *mg;
2085     AMT *amtp;
2086     U32 newgen;
2087     struct mro_meta* stash_meta;
2088
2089     if (!stash || !HvNAME_get(stash))
2090         return NULL;
2091
2092     stash_meta = HvMROMETA(stash);
2093     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2094
2095     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2096     if (!mg) {
2097       do_update:
2098         /* If we're looking up a destructor to invoke, we must avoid
2099          * that Gv_AMupdate croaks, because we might be dying already */
2100         if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2101             /* and if it didn't found a destructor, we fall back
2102              * to a simpler method that will only look for the
2103              * destructor instead of the whole magic */
2104             if (id == DESTROY_amg) {
2105                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2106                 if (gv)
2107                     return GvCV(gv);
2108             }
2109             return NULL;
2110         }
2111         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2112     }
2113     assert(mg);
2114     amtp = (AMT*)mg->mg_ptr;
2115     if ( amtp->was_ok_am != PL_amagic_generation
2116          || amtp->was_ok_sub != newgen )
2117         goto do_update;
2118     if (AMT_AMAGIC(amtp)) {
2119         CV * const ret = amtp->table[id];
2120         if (ret && isGV(ret)) {         /* Autoloading stab */
2121             /* Passing it through may have resulted in a warning
2122                "Inherited AUTOLOAD for a non-method deprecated", since
2123                our caller is going through a function call, not a method call.
2124                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2125             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2126
2127             if (gv && GvCV(gv))
2128                 return GvCV(gv);
2129         }
2130         return ret;
2131     }
2132
2133     return NULL;
2134 }
2135
2136
2137 /* Implement tryAMAGICun_MG macro.
2138    Do get magic, then see if the stack arg is overloaded and if so call it.
2139    Flags:
2140         AMGf_set     return the arg using SETs rather than assigning to
2141                      the targ
2142         AMGf_numeric apply sv_2num to the stack arg.
2143 */
2144
2145 bool
2146 Perl_try_amagic_un(pTHX_ int method, int flags) {
2147     dVAR;
2148     dSP;
2149     SV* tmpsv;
2150     SV* const arg = TOPs;
2151
2152     SvGETMAGIC(arg);
2153
2154     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2155                                               AMGf_noright | AMGf_unary))) {
2156         if (flags & AMGf_set) {
2157             SETs(tmpsv);
2158         }
2159         else {
2160             dTARGET;
2161             if (SvPADMY(TARG)) {
2162                 sv_setsv(TARG, tmpsv);
2163                 SETTARG;
2164             }
2165             else
2166                 SETs(tmpsv);
2167         }
2168         PUTBACK;
2169         return TRUE;
2170     }
2171
2172     if ((flags & AMGf_numeric) && SvROK(arg))
2173         *sp = sv_2num(arg);
2174     return FALSE;
2175 }
2176
2177
2178 /* Implement tryAMAGICbin_MG macro.
2179    Do get magic, then see if the two stack args are overloaded and if so
2180    call it.
2181    Flags:
2182         AMGf_set     return the arg using SETs rather than assigning to
2183                      the targ
2184         AMGf_assign  op may be called as mutator (eg +=)
2185         AMGf_numeric apply sv_2num to the stack arg.
2186 */
2187
2188 bool
2189 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2190     dVAR;
2191     dSP;
2192     SV* const left = TOPm1s;
2193     SV* const right = TOPs;
2194
2195     SvGETMAGIC(left);
2196     if (left != right)
2197         SvGETMAGIC(right);
2198
2199     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2200         SV * const tmpsv = amagic_call(left, right, method,
2201                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2202         if (tmpsv) {
2203             if (flags & AMGf_set) {
2204                 (void)POPs;
2205                 SETs(tmpsv);
2206             }
2207             else {
2208                 dATARGET;
2209                 (void)POPs;
2210                 if (opASSIGN || SvPADMY(TARG)) {
2211                     sv_setsv(TARG, tmpsv);
2212                     SETTARG;
2213                 }
2214                 else
2215                     SETs(tmpsv);
2216             }
2217             PUTBACK;
2218             return TRUE;
2219         }
2220     }
2221     if(left==right && SvGMAGICAL(left)) {
2222         SV * const left = sv_newmortal();
2223         *(sp-1) = left;
2224         /* Print the uninitialized warning now, so it includes the vari-
2225            able name. */
2226         if (!SvOK(right)) {
2227             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2228             sv_setsv_flags(left, &PL_sv_no, 0);
2229         }
2230         else sv_setsv_flags(left, right, 0);
2231         SvGETMAGIC(right);
2232     }
2233     if (flags & AMGf_numeric) {
2234         if (SvROK(TOPm1s))
2235             *(sp-1) = sv_2num(TOPm1s);
2236         if (SvROK(right))
2237             *sp     = sv_2num(right);
2238     }
2239     return FALSE;
2240 }
2241
2242 SV *
2243 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2244     SV *tmpsv = NULL;
2245
2246     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2247
2248     while (SvAMAGIC(ref) &&
2249            (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2250                                 AMGf_noright | AMGf_unary))) {
2251         if (!SvROK(tmpsv))
2252             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2253         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2254             /* Bail out if it returns us the same reference.  */
2255             return tmpsv;
2256         }
2257         ref = tmpsv;
2258     }
2259     return tmpsv ? tmpsv : ref;
2260 }
2261
2262 SV*
2263 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2264 {
2265   dVAR;
2266   MAGIC *mg;
2267   CV *cv=NULL;
2268   CV **cvp=NULL, **ocvp=NULL;
2269   AMT *amtp=NULL, *oamtp=NULL;
2270   int off = 0, off1, lr = 0, notfound = 0;
2271   int postpr = 0, force_cpy = 0;
2272   int assign = AMGf_assign & flags;
2273   const int assignshift = assign ? 1 : 0;
2274   int use_default_op = 0;
2275 #ifdef DEBUGGING
2276   int fl=0;
2277 #endif
2278   HV* stash=NULL;
2279
2280   PERL_ARGS_ASSERT_AMAGIC_CALL;
2281
2282   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2283       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2284
2285       if ( !lex_mask || !SvOK(lex_mask) )
2286           /* overloading lexically disabled */
2287           return NULL;
2288       else if ( lex_mask && SvPOK(lex_mask) ) {
2289           /* we have an entry in the hints hash, check if method has been
2290            * masked by overloading.pm */
2291           STRLEN len;
2292           const int offset = method / 8;
2293           const int bit    = method % 8;
2294           char *pv = SvPV(lex_mask, len);
2295
2296           /* Bit set, so this overloading operator is disabled */
2297           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2298               return NULL;
2299       }
2300   }
2301
2302   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2303       && (stash = SvSTASH(SvRV(left)))
2304       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2305       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2306                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2307                         : NULL))
2308       && ((cv = cvp[off=method+assignshift])
2309           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2310                                                           * usual method */
2311                   (
2312 #ifdef DEBUGGING
2313                    fl = 1,
2314 #endif
2315                    cv = cvp[off=method])))) {
2316     lr = -1;                    /* Call method for left argument */
2317   } else {
2318     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2319       int logic;
2320
2321       /* look for substituted methods */
2322       /* In all the covered cases we should be called with assign==0. */
2323          switch (method) {
2324          case inc_amg:
2325            force_cpy = 1;
2326            if ((cv = cvp[off=add_ass_amg])
2327                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2328              right = &PL_sv_yes; lr = -1; assign = 1;
2329            }
2330            break;
2331          case dec_amg:
2332            force_cpy = 1;
2333            if ((cv = cvp[off = subtr_ass_amg])
2334                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2335              right = &PL_sv_yes; lr = -1; assign = 1;
2336            }
2337            break;
2338          case bool__amg:
2339            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2340            break;
2341          case numer_amg:
2342            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2343            break;
2344          case string_amg:
2345            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2346            break;
2347          case not_amg:
2348            (void)((cv = cvp[off=bool__amg])
2349                   || (cv = cvp[off=numer_amg])
2350                   || (cv = cvp[off=string_amg]));
2351            if (cv)
2352                postpr = 1;
2353            break;
2354          case copy_amg:
2355            {
2356              /*
2357                   * SV* ref causes confusion with the interpreter variable of
2358                   * the same name
2359                   */
2360              SV* const tmpRef=SvRV(left);
2361              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2362                 /*
2363                  * Just to be extra cautious.  Maybe in some
2364                  * additional cases sv_setsv is safe, too.
2365                  */
2366                 SV* const newref = newSVsv(tmpRef);
2367                 SvOBJECT_on(newref);
2368                 /* As a bit of a source compatibility hack, SvAMAGIC() and
2369                    friends dereference an RV, to behave the same was as when
2370                    overloading was stored on the reference, not the referant.
2371                    Hence we can't use SvAMAGIC_on()
2372                 */
2373                 SvFLAGS(newref) |= SVf_AMAGIC;
2374                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2375                 return newref;
2376              }
2377            }
2378            break;
2379          case abs_amg:
2380            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2381                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2382              SV* const nullsv=sv_2mortal(newSViv(0));
2383              if (off1==lt_amg) {
2384                SV* const lessp = amagic_call(left,nullsv,
2385                                        lt_amg,AMGf_noright);
2386                logic = SvTRUE(lessp);
2387              } else {
2388                SV* const lessp = amagic_call(left,nullsv,
2389                                        ncmp_amg,AMGf_noright);
2390                logic = (SvNV(lessp) < 0);
2391              }
2392              if (logic) {
2393                if (off==subtr_amg) {
2394                  right = left;
2395                  left = nullsv;
2396                  lr = 1;
2397                }
2398              } else {
2399                return left;
2400              }
2401            }
2402            break;
2403          case neg_amg:
2404            if ((cv = cvp[off=subtr_amg])) {
2405              right = left;
2406              left = sv_2mortal(newSViv(0));
2407              lr = 1;
2408            }
2409            break;
2410          case int_amg:
2411          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2412          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2413          case regexp_amg:
2414              /* FAIL safe */
2415              return NULL;       /* Delegate operation to standard mechanisms. */
2416              break;
2417          case to_sv_amg:
2418          case to_av_amg:
2419          case to_hv_amg:
2420          case to_gv_amg:
2421          case to_cv_amg:
2422              /* FAIL safe */
2423              return left;       /* Delegate operation to standard mechanisms. */
2424              break;
2425          default:
2426            goto not_found;
2427          }
2428          if (!cv) goto not_found;
2429     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2430                && (stash = SvSTASH(SvRV(right)))
2431                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2432                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2433                           ? (amtp = (AMT*)mg->mg_ptr)->table
2434                           : NULL))
2435                && (cv = cvp[off=method])) { /* Method for right
2436                                              * argument found */
2437       lr=1;
2438     } else if (((cvp && amtp->fallback > AMGfallNEVER)
2439                 || (ocvp && oamtp->fallback > AMGfallNEVER))
2440                && !(flags & AMGf_unary)) {
2441                                 /* We look for substitution for
2442                                  * comparison operations and
2443                                  * concatenation */
2444       if (method==concat_amg || method==concat_ass_amg
2445           || method==repeat_amg || method==repeat_ass_amg) {
2446         return NULL;            /* Delegate operation to string conversion */
2447       }
2448       off = -1;
2449       switch (method) {
2450          case lt_amg:
2451          case le_amg:
2452          case gt_amg:
2453          case ge_amg:
2454          case eq_amg:
2455          case ne_amg:
2456              off = ncmp_amg;
2457              break;
2458          case slt_amg:
2459          case sle_amg:
2460          case sgt_amg:
2461          case sge_amg:
2462          case seq_amg:
2463          case sne_amg:
2464              off = scmp_amg;
2465              break;
2466          }
2467       if (off != -1) {
2468           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2469               cv = ocvp[off];
2470               lr = -1;
2471           }
2472           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2473               cv = cvp[off];
2474               lr = 1;
2475           }
2476       }
2477       if (cv)
2478           postpr = 1;
2479       else
2480           goto not_found;
2481     } else {
2482     not_found:                  /* No method found, either report or croak */
2483       switch (method) {
2484          case to_sv_amg:
2485          case to_av_amg:
2486          case to_hv_amg:
2487          case to_gv_amg:
2488          case to_cv_amg:
2489              /* FAIL safe */
2490              return left;       /* Delegate operation to standard mechanisms. */
2491              break;
2492       }
2493       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2494         notfound = 1; lr = -1;
2495       } else if (cvp && (cv=cvp[nomethod_amg])) {
2496         notfound = 1; lr = 1;
2497       } else if ((use_default_op =
2498                   (!ocvp || oamtp->fallback >= AMGfallYES)
2499                   && (!cvp || amtp->fallback >= AMGfallYES))
2500                  && !DEBUG_o_TEST) {
2501         /* Skip generating the "no method found" message.  */
2502         return NULL;
2503       } else {
2504         SV *msg;
2505         if (off==-1) off=method;
2506         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2507                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
2508                       AMG_id2name(method + assignshift),
2509                       (flags & AMGf_unary ? " " : "\n\tleft "),
2510                       SvAMAGIC(left)?
2511                         "in overloaded package ":
2512                         "has no overloaded magic",
2513                       SvAMAGIC(left)?
2514                         HvNAME_get(SvSTASH(SvRV(left))):
2515                         "",
2516                       SvAMAGIC(right)?
2517                         ",\n\tright argument in overloaded package ":
2518                         (flags & AMGf_unary
2519                          ? ""
2520                          : ",\n\tright argument has no overloaded magic"),
2521                       SvAMAGIC(right)?
2522                         HvNAME_get(SvSTASH(SvRV(right))):
2523                         ""));
2524         if (use_default_op) {
2525           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2526         } else {
2527           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2528         }
2529         return NULL;
2530       }
2531       force_cpy = force_cpy || assign;
2532     }
2533   }
2534 #ifdef DEBUGGING
2535   if (!notfound) {
2536     DEBUG_o(Perl_deb(aTHX_
2537                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2538                      AMG_id2name(off),
2539                      method+assignshift==off? "" :
2540                      " (initially \"",
2541                      method+assignshift==off? "" :
2542                      AMG_id2name(method+assignshift),
2543                      method+assignshift==off? "" : "\")",
2544                      flags & AMGf_unary? "" :
2545                      lr==1 ? " for right argument": " for left argument",
2546                      flags & AMGf_unary? " for argument" : "",
2547                      stash ? HvNAME_get(stash) : "null",
2548                      fl? ",\n\tassignment variant used": "") );
2549   }
2550 #endif
2551     /* Since we use shallow copy during assignment, we need
2552      * to dublicate the contents, probably calling user-supplied
2553      * version of copy operator
2554      */
2555     /* We need to copy in following cases:
2556      * a) Assignment form was called.
2557      *          assignshift==1,  assign==T, method + 1 == off
2558      * b) Increment or decrement, called directly.
2559      *          assignshift==0,  assign==0, method + 0 == off
2560      * c) Increment or decrement, translated to assignment add/subtr.
2561      *          assignshift==0,  assign==T,
2562      *          force_cpy == T
2563      * d) Increment or decrement, translated to nomethod.
2564      *          assignshift==0,  assign==0,
2565      *          force_cpy == T
2566      * e) Assignment form translated to nomethod.
2567      *          assignshift==1,  assign==T, method + 1 != off
2568      *          force_cpy == T
2569      */
2570     /*  off is method, method+assignshift, or a result of opcode substitution.
2571      *  In the latter case assignshift==0, so only notfound case is important.
2572      */
2573   if (( (method + assignshift == off)
2574         && (assign || (method == inc_amg) || (method == dec_amg)))
2575       || force_cpy)
2576   {
2577       /* newSVsv does not behave as advertised, so we copy missing
2578        * information by hand */
2579       SV *tmpRef = SvRV(left);
2580       SV *rv_copy;
2581       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2582           SvRV_set(left, rv_copy);
2583           SvSETMAGIC(left);
2584           SvREFCNT_dec(tmpRef);
2585       }
2586   }
2587
2588   {
2589     dSP;
2590     BINOP myop;
2591     SV* res;
2592     const bool oldcatch = CATCH_GET;
2593
2594     CATCH_SET(TRUE);
2595     Zero(&myop, 1, BINOP);
2596     myop.op_last = (OP *) &myop;
2597     myop.op_next = NULL;
2598     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2599
2600     PUSHSTACKi(PERLSI_OVERLOAD);
2601     ENTER;
2602     SAVEOP();
2603     PL_op = (OP *) &myop;
2604     if (PERLDB_SUB && PL_curstash != PL_debstash)
2605         PL_op->op_private |= OPpENTERSUB_DB;
2606     PUTBACK;
2607     Perl_pp_pushmark(aTHX);
2608
2609     EXTEND(SP, notfound + 5);
2610     PUSHs(lr>0? right: left);
2611     PUSHs(lr>0? left: right);
2612     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2613     if (notfound) {
2614       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2615                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2616     }
2617     PUSHs(MUTABLE_SV(cv));
2618     PUTBACK;
2619
2620     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2621       CALLRUNOPS(aTHX);
2622     LEAVE;
2623     SPAGAIN;
2624
2625     res=POPs;
2626     PUTBACK;
2627     POPSTACK;
2628     CATCH_SET(oldcatch);
2629
2630     if (postpr) {
2631       int ans;
2632       switch (method) {
2633       case le_amg:
2634       case sle_amg:
2635         ans=SvIV(res)<=0; break;
2636       case lt_amg:
2637       case slt_amg:
2638         ans=SvIV(res)<0; break;
2639       case ge_amg:
2640       case sge_amg:
2641         ans=SvIV(res)>=0; break;
2642       case gt_amg:
2643       case sgt_amg:
2644         ans=SvIV(res)>0; break;
2645       case eq_amg:
2646       case seq_amg:
2647         ans=SvIV(res)==0; break;
2648       case ne_amg:
2649       case sne_amg:
2650         ans=SvIV(res)!=0; break;
2651       case inc_amg:
2652       case dec_amg:
2653         SvSetSV(left,res); return left;
2654       case not_amg:
2655         ans=!SvTRUE(res); break;
2656       default:
2657         ans=0; break;
2658       }
2659       return boolSV(ans);
2660     } else if (method==copy_amg) {
2661       if (!SvROK(res)) {
2662         Perl_croak(aTHX_ "Copy method did not return a reference");
2663       }
2664       return SvREFCNT_inc(SvRV(res));
2665     } else {
2666       return res;
2667     }
2668   }
2669 }
2670
2671 void
2672 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2673 {
2674     dVAR;
2675     U32 hash;
2676
2677     PERL_ARGS_ASSERT_GV_NAME_SET;
2678     PERL_UNUSED_ARG(flags);
2679
2680     if (len > I32_MAX)
2681         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2682
2683     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2684         unshare_hek(GvNAME_HEK(gv));
2685     }
2686
2687     PERL_HASH(hash, name, len);
2688     GvNAME_HEK(gv) = share_hek(name, len, hash);
2689 }
2690
2691 /*
2692 =for apidoc gv_try_downgrade
2693
2694 If the typeglob C<gv> can be expressed more succinctly, by having
2695 something other than a real GV in its place in the stash, replace it
2696 with the optimised form.  Basic requirements for this are that C<gv>
2697 is a real typeglob, is sufficiently ordinary, and is only referenced
2698 from its package.  This function is meant to be used when a GV has been
2699 looked up in part to see what was there, causing upgrading, but based
2700 on what was found it turns out that the real GV isn't required after all.
2701
2702 If C<gv> is a completely empty typeglob, it is deleted from the stash.
2703
2704 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2705 sub, the typeglob is replaced with a scalar-reference placeholder that
2706 more compactly represents the same thing.
2707
2708 =cut
2709 */
2710
2711 void
2712 Perl_gv_try_downgrade(pTHX_ GV *gv)
2713 {
2714     HV *stash;
2715     CV *cv;
2716     HEK *namehek;
2717     SV **gvp;
2718     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
2719
2720     /* XXX Why and where does this leave dangling pointers during global
2721        destruction? */
2722     if (PL_phase == PERL_PHASE_DESTRUCT) return;
2723
2724     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
2725             !SvOBJECT(gv) && !SvREADONLY(gv) &&
2726             isGV_with_GP(gv) && GvGP(gv) &&
2727             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
2728             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
2729             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2730         return;
2731     if (SvMAGICAL(gv)) {
2732         MAGIC *mg;
2733         /* only backref magic is allowed */
2734         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
2735             return;
2736         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
2737             if (mg->mg_type != PERL_MAGIC_backref)
2738                 return;
2739         }
2740     }
2741     cv = GvCV(gv);
2742     if (!cv) {
2743         HEK *gvnhek = GvNAME_HEK(gv);
2744         (void)hv_delete(stash, HEK_KEY(gvnhek),
2745             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
2746     } else if (GvMULTI(gv) && cv &&
2747             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
2748             CvSTASH(cv) == stash && CvGV(cv) == gv &&
2749             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
2750             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
2751             (namehek = GvNAME_HEK(gv)) &&
2752             (gvp = hv_fetch(stash, HEK_KEY(namehek),
2753                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
2754             *gvp == (SV*)gv) {
2755         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
2756         SvREFCNT(gv) = 0;
2757         sv_clear((SV*)gv);
2758         SvREFCNT(gv) = 1;
2759         SvFLAGS(gv) = SVt_IV|SVf_ROK;
2760         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
2761                                 STRUCT_OFFSET(XPVIV, xiv_iv));
2762         SvRV_set(gv, value);
2763     }
2764 }
2765
2766 #include "XSUB.h"
2767
2768 static void
2769 core_xsub(pTHX_ CV* cv)
2770 {
2771     Perl_croak(aTHX_
2772        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
2773     );
2774 }
2775
2776 /*
2777  * Local variables:
2778  * c-indentation-style: bsd
2779  * c-basic-offset: 4
2780  * indent-tabs-mode: t
2781  * End:
2782  *
2783  * ex: set ts=8 sts=4 sw=4 noet:
2784  */