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