gv.c

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