gv.c

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