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