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