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