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