gv.c

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