gv.c

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