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