gv.c

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