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