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