gv.c

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