gv.c

   1 /*    gv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
  13  * of your inquisitiveness, I shall spend all the rest of my days in answering
  14  * you.  What more do you want to know?'
  15  *   'The names of all the stars, and of all living things, and the whole
  16  * history of Middle-earth and Over-heaven and of the Sundering Seas,'
  17  * laughed Pippin.
  18  *
  19  *     [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
  20  */
  21
  22 /*
  23 =head1 GV Functions
  24
  25 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
  26 It is a structure that holds a pointer to a scalar, an array, a hash etc,
  27 corresponding to $foo, @foo, %foo.
  28
  29 GVs are usually found as values in stashes (symbol table hashes) where
  30 Perl stores its global variables.
  31
  32 =cut
  33 */
  34
  35 #include "EXTERN.h"
  36 #define PERL_IN_GV_C
  37 #include "perl.h"
  38 #include "overload.c"
  39
  40 static const char S_autoload[] = "AUTOLOAD";
  41 static const STRLEN S_autolen = sizeof(S_autoload)-1;
  42
  43 GV *
  44 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
  45 {
  46     SV **where;
  47
  48     if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) {
  49         const char *what;
  50         if (type == SVt_PVIO) {
  51             /*
  52              * if it walks like a dirhandle, then let's assume that
  53              * this is a dirhandle.
  54              */
  55             what = PL_op->op_type ==  OP_READDIR ||
  56                 PL_op->op_type ==  OP_TELLDIR ||
  57                 PL_op->op_type ==  OP_SEEKDIR ||
  58                 PL_op->op_type ==  OP_REWINDDIR ||
  59                 PL_op->op_type ==  OP_CLOSEDIR ?
  60                 "dirhandle" : "filehandle";
  61             /* diag_listed_as: Bad symbol for filehandle */
  62         } else if (type == SVt_PVHV) {
  63             what = "hash";
  64         } else {
  65             what = type == SVt_PVAV ? "array" : "scalar";
  66         }
  67         Perl_croak(aTHX_ "Bad symbol for %s", what);
  68     }
  69
  70     if (type == SVt_PVHV) {
  71         where = (SV **)&GvHV(gv);
  72     } else if (type == SVt_PVAV) {
  73         where = (SV **)&GvAV(gv);
  74     } else if (type == SVt_PVIO) {
  75         where = (SV **)&GvIOp(gv);
  76     } else {
  77         where = &GvSV(gv);
  78     }
  79
  80     if (!*where)
  81         *where = newSV_type(type);
  82     return gv;
  83 }
  84
  85 GV *
  86 Perl_gv_fetchfile(pTHX_ const char *name)
  87 {
  88     PERL_ARGS_ASSERT_GV_FETCHFILE;
  89     return gv_fetchfile_flags(name, strlen(name), 0);
  90 }
  91
  92 GV *
  93 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
  94                         const U32 flags)
  95 {
  96     dVAR;
  97     char smallbuf[128];
  98     char *tmpbuf;
  99     const STRLEN tmplen = namelen + 2;
 100     GV *gv;
 101
 102     PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
 103     PERL_UNUSED_ARG(flags);
 104
 105     if (!PL_defstash)
 106         return NULL;
 107
 108     if (tmplen <= sizeof smallbuf)
 109         tmpbuf = smallbuf;
 110     else
 111         Newx(tmpbuf, tmplen, char);
 112     /* This is where the debugger's %{"::_<$filename"} hash is created */
 113     tmpbuf[0] = '_';
 114     tmpbuf[1] = '<';
 115     memcpy(tmpbuf + 2, name, namelen);
 116     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
 117     if (!isGV(gv)) {
 118         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
 119 #ifdef PERL_DONT_CREATE_GVSV
 120         GvSV(gv) = newSVpvn(name, namelen);
 121 #else
 122         sv_setpvn(GvSV(gv), name, namelen);
 123 #endif
 124         if (PERLDB_LINE || PERLDB_SAVESRC)
 125             hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
 126     }
 127     if (tmpbuf != smallbuf)
 128         Safefree(tmpbuf);
 129     return gv;
 130 }
 131
 132 /*
 133 =for apidoc gv_const_sv
 134
 135 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
 136 inlining, or C<gv> is a placeholder reference that would be promoted to such
 137 a typeglob, then returns the value returned by the sub.  Otherwise, returns
 138 NULL.
 139
 140 =cut
 141 */
 142
 143 SV *
 144 Perl_gv_const_sv(pTHX_ GV *gv)
 145 {
 146     PERL_ARGS_ASSERT_GV_CONST_SV;
 147
 148     if (SvTYPE(gv) == SVt_PVGV)
 149         return cv_const_sv(GvCVu(gv));
 150     return SvROK(gv) ? SvRV(gv) : NULL;
 151 }
 152
 153 GP *
 154 Perl_newGP(pTHX_ GV *const gv)
 155 {
 156     GP *gp;
 157     U32 hash;
 158 #ifdef USE_ITHREADS
 159     const char *const file
 160         = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
 161     const STRLEN len = strlen(file);
 162 #else
 163     SV *const temp_sv = CopFILESV(PL_curcop);
 164     const char *file;
 165     STRLEN len;
 166
 167     PERL_ARGS_ASSERT_NEWGP;
 168
 169     if (temp_sv) {
 170         file = SvPVX(temp_sv);
 171         len = SvCUR(temp_sv);
 172     } else {
 173         file = "";
 174         len = 0;
 175     }
 176 #endif
 177
 178     PERL_HASH(hash, file, len);
 179
 180     Newxz(gp, 1, GP);
 181
 182 #ifndef PERL_DONT_CREATE_GVSV
 183     gp->gp_sv = newSV(0);
 184 #endif
 185
 186     gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
 187     /* XXX Ideally this cast would be replaced with a change to const char*
 188        in the struct.  */
 189     gp->gp_file_hek = share_hek(file, len, hash);
 190     gp->gp_egv = gv;
 191     gp->gp_refcnt = 1;
 192
 193     return gp;
 194 }
 195
 196 /* 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 GV *
 967 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 968                        const svtype sv_type)
 969 {
 970     dVAR;
 971     register const char *name = nambeg;
 972     register GV *gv = NULL;
 973     GV**gvp;
 974     I32 len;
 975     register const char *name_cursor;
 976     HV *stash = NULL;
 977     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
 978     const I32 no_expand = flags & GV_NOEXPAND;
 979     const I32 add = flags & ~GV_NOADD_MASK;
 980     const char *const name_end = nambeg + full_len;
 981     const char *const name_em1 = name_end - 1;
 982     U32 faking_it;
 983
 984     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
 985
 986     if (flags & GV_NOTQUAL) {
 987         /* Caller promised that there is no stash, so we can skip the check. */
 988         len = full_len;
 989         goto no_stash;
 990     }
 991
 992     if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
 993         /* accidental stringify on a GV? */
 994         name++;
 995     }
 996
 997     for (name_cursor = name; name_cursor < name_end; name_cursor++) {
 998         if ((*name_cursor == ':' && name_cursor < name_em1
 999              && name_cursor[1] == ':')
1000             || (*name_cursor == '\'' && name_cursor[1]))
1001         {
1002             if (!stash)
1003                 stash = PL_defstash;
1004             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1005                 return NULL;
1006
1007             len = name_cursor - name;
1008             if (len > 0) {
1009                 char smallbuf[128];
1010                 char *tmpbuf;
1011
1012                 if (len + 2 <= (I32)sizeof (smallbuf))
1013                     tmpbuf = smallbuf;
1014                 else
1015                     Newx(tmpbuf, len+2, char);
1016                 Copy(name, tmpbuf, len, char);
1017                 tmpbuf[len++] = ':';
1018                 tmpbuf[len++] = ':';
1019                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
1020                 gv = gvp ? *gvp : NULL;
1021                 if (gv && gv != (const GV *)&PL_sv_undef) {
1022                     if (SvTYPE(gv) != SVt_PVGV)
1023                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
1024                     else
1025                         GvMULTI_on(gv);
1026                 }
1027                 if (tmpbuf != smallbuf)
1028                     Safefree(tmpbuf);
1029                 if (!gv || gv == (const GV *)&PL_sv_undef)
1030                     return NULL;
1031
1032                 if (!(stash = GvHV(gv)))
1033                     stash = GvHV(gv) = newHV();
1034
1035                 if (!HvNAME_get(stash))
1036                     hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
1037             }
1038
1039             if (*name_cursor == ':')
1040                 name_cursor++;
1041             name_cursor++;
1042             name = name_cursor;
1043             if (name == name_end)
1044                 return gv
1045                     ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1046         }
1047     }
1048     len = name_cursor - name;
1049
1050     /* No stash in name, so see how we can default */
1051
1052     if (!stash) {
1053     no_stash:
1054         if (len && isIDFIRST_lazy(name)) {
1055             bool global = FALSE;
1056
1057             switch (len) {
1058             case 1:
1059                 if (*name == '_')
1060                     global = TRUE;
1061                 break;
1062             case 3:
1063                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1064                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1065                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1066                     global = TRUE;
1067                 break;
1068             case 4:
1069                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1070                     && name[3] == 'V')
1071                     global = TRUE;
1072                 break;
1073             case 5:
1074                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1075                     && name[3] == 'I' && name[4] == 'N')
1076                     global = TRUE;
1077                 break;
1078             case 6:
1079                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1080                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1081                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1082                     global = TRUE;
1083                 break;
1084             case 7:
1085                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1086                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1087                     && name[6] == 'T')
1088                     global = TRUE;
1089                 break;
1090             }
1091
1092             if (global)
1093                 stash = PL_defstash;
1094             else if (IN_PERL_COMPILETIME) {
1095                 stash = PL_curstash;
1096                 if (add && (PL_hints & HINT_STRICT_VARS) &&
1097                     sv_type != SVt_PVCV &&
1098                     sv_type != SVt_PVGV &&
1099                     sv_type != SVt_PVFM &&
1100                     sv_type != SVt_PVIO &&
1101                     !(len == 1 && sv_type == SVt_PV &&
1102                       (*name == 'a' || *name == 'b')) )
1103                 {
1104                     gvp = (GV**)hv_fetch(stash,name,len,0);
1105                     if (!gvp ||
1106                         *gvp == (const GV *)&PL_sv_undef ||
1107                         SvTYPE(*gvp) != SVt_PVGV)
1108                     {
1109                         stash = NULL;
1110                     }
1111                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1112                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1113                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1114                     {
1115                         /* diag_listed_as: Variable "%s" is not imported%s */
1116                         Perl_ck_warner_d(
1117                             aTHX_ packWARN(WARN_MISC),
1118                             "Variable \"%c%s\" is not imported",
1119                             sv_type == SVt_PVAV ? '@' :
1120                             sv_type == SVt_PVHV ? '%' : '$',
1121                             name);
1122                         if (GvCVu(*gvp))
1123                             Perl_ck_warner_d(
1124                                 aTHX_ packWARN(WARN_MISC),
1125                                 "\t(Did you mean &%s instead?)\n", name
1126                             );
1127                         stash = NULL;
1128                     }
1129                 }
1130             }
1131             else
1132                 stash = CopSTASH(PL_curcop);
1133         }
1134         else
1135             stash = PL_defstash;
1136     }
1137
1138     /* By this point we should have a stash and a name */
1139
1140     if (!stash) {
1141         if (add) {
1142             SV * const err = Perl_mess(aTHX_
1143                  "Global symbol \"%s%s\" requires explicit package name",
1144                  (sv_type == SVt_PV ? "$"
1145                   : sv_type == SVt_PVAV ? "@"
1146                   : sv_type == SVt_PVHV ? "%"
1147                   : ""), name);
1148             GV *gv;
1149             if (USE_UTF8_IN_NAMES)
1150                 SvUTF8_on(err);
1151             qerror(err);
1152             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1153             if(!gv) {
1154                 /* symbol table under destruction */
1155                 return NULL;
1156             }
1157             stash = GvHV(gv);
1158         }
1159         else
1160             return NULL;
1161     }
1162
1163     if (!SvREFCNT(stash))       /* symbol table under destruction */
1164         return NULL;
1165
1166     gvp = (GV**)hv_fetch(stash,name,len,add);
1167     if (!gvp || *gvp == (const GV *)&PL_sv_undef)
1168         return NULL;
1169     gv = *gvp;
1170     if (SvTYPE(gv) == SVt_PVGV) {
1171         if (add) {
1172             GvMULTI_on(gv);
1173             gv_init_sv(gv, sv_type);
1174             if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1175                 if (*name == '!')
1176                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1177                 else if (*name == '-' || *name == '+')
1178                     require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1179             }
1180         }
1181         return gv;
1182     } else if (no_init) {
1183         return gv;
1184     } else if (no_expand && SvROK(gv)) {
1185         return gv;
1186     }
1187
1188     /* Adding a new symbol.
1189        Unless of course there was already something non-GV here, in which case
1190        we want to behave as if there was always a GV here, containing some sort
1191        of subroutine.
1192        Otherwise we run the risk of creating things like GvIO, which can cause
1193        subtle bugs. eg the one that tripped up SQL::Translator  */
1194
1195     faking_it = SvOK(gv);
1196
1197     if (add & GV_ADDWARN)
1198         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1199     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1200     gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
1201
1202     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1203                                             : (PL_dowarn & G_WARN_ON ) ) )
1204         GvMULTI_on(gv) ;
1205
1206     /* set up magic where warranted */
1207     if (len > 1) {
1208 #ifndef EBCDIC
1209         if (*name > 'V' ) {
1210             NOOP;
1211             /* Nothing else to do.
1212                The compiler will probably turn the switch statement into a
1213                branch table. Make sure we avoid even that small overhead for
1214                the common case of lower case variable names.  */
1215         } else
1216 #endif
1217         {
1218             const char * const name2 = name + 1;
1219             switch (*name) {
1220             case 'A':
1221                 if (strEQ(name2, "RGV")) {
1222                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1223                 }
1224                 else if (strEQ(name2, "RGVOUT")) {
1225                     GvMULTI_on(gv);
1226                 }
1227                 break;
1228             case 'E':
1229                 if (strnEQ(name2, "XPORT", 5))
1230                     GvMULTI_on(gv);
1231                 break;
1232             case 'I':
1233                 if (strEQ(name2, "SA")) {
1234                     AV* const av = GvAVn(gv);
1235                     GvMULTI_on(gv);
1236                     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1237                              NULL, 0);
1238                     /* NOTE: No support for tied ISA */
1239                     if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
1240                         && AvFILLp(av) == -1)
1241                         {
1242                             av_push(av, newSVpvs("NDBM_File"));
1243                             gv_stashpvs("NDBM_File", GV_ADD);
1244                             av_push(av, newSVpvs("DB_File"));
1245                             gv_stashpvs("DB_File", GV_ADD);
1246                             av_push(av, newSVpvs("GDBM_File"));
1247                             gv_stashpvs("GDBM_File", GV_ADD);
1248                             av_push(av, newSVpvs("SDBM_File"));
1249                             gv_stashpvs("SDBM_File", GV_ADD);
1250                             av_push(av, newSVpvs("ODBM_File"));
1251                             gv_stashpvs("ODBM_File", GV_ADD);
1252                         }
1253                 }
1254                 break;
1255             case 'O':
1256                 if (strEQ(name2, "VERLOAD")) {
1257                     HV* const hv = GvHVn(gv);
1258                     GvMULTI_on(gv);
1259                     hv_magic(hv, NULL, PERL_MAGIC_overload);
1260                 }
1261                 break;
1262             case 'S':
1263                 if (strEQ(name2, "IG")) {
1264                     HV *hv;
1265                     I32 i;
1266                     if (!PL_psig_name) {
1267                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1268                         Newxz(PL_psig_pend, SIG_SIZE, int);
1269                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1270                     } else {
1271                         /* I think that the only way to get here is to re-use an
1272                            embedded perl interpreter, where the previous
1273                            use didn't clean up fully because
1274                            PL_perl_destruct_level was 0. I'm not sure that we
1275                            "support" that, in that I suspect in that scenario
1276                            there are sufficient other garbage values left in the
1277                            interpreter structure that something else will crash
1278                            before we get here. I suspect that this is one of
1279                            those "doctor, it hurts when I do this" bugs.  */
1280                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1281                         Zero(PL_psig_pend, SIG_SIZE, int);
1282                     }
1283                     GvMULTI_on(gv);
1284                     hv = GvHVn(gv);
1285                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1286                     for (i = 1; i < SIG_SIZE; i++) {
1287                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1288                         if (init)
1289                             sv_setsv(*init, &PL_sv_undef);
1290                     }
1291                 }
1292                 break;
1293             case 'V':
1294                 if (strEQ(name2, "ERSION"))
1295                     GvMULTI_on(gv);
1296                 break;
1297             case '\003':        /* $^CHILD_ERROR_NATIVE */
1298                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1299                     goto magicalize;
1300                 break;
1301             case '\005':        /* $^ENCODING */
1302                 if (strEQ(name2, "NCODING"))
1303                     goto magicalize;
1304                 break;
1305             case '\015':        /* $^MATCH */
1306                 if (strEQ(name2, "ATCH"))
1307                     goto magicalize;
1308             case '\017':        /* $^OPEN */
1309                 if (strEQ(name2, "PEN"))
1310                     goto magicalize;
1311                 break;
1312             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1313                 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1314                     goto magicalize;
1315             case '\024':        /* ${^TAINT} */
1316                 if (strEQ(name2, "AINT"))
1317                     goto ro_magicalize;
1318                 break;
1319             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1320                 if (strEQ(name2, "NICODE"))
1321                     goto ro_magicalize;
1322                 if (strEQ(name2, "TF8LOCALE"))
1323                     goto ro_magicalize;
1324                 if (strEQ(name2, "TF8CACHE"))
1325                     goto magicalize;
1326                 break;
1327             case '\027':        /* $^WARNING_BITS */
1328                 if (strEQ(name2, "ARNING_BITS"))
1329                     goto magicalize;
1330                 break;
1331             case '1':
1332             case '2':
1333             case '3':
1334             case '4':
1335             case '5':
1336             case '6':
1337             case '7':
1338             case '8':
1339             case '9':
1340             {
1341                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1342                    this test  */
1343                 /* This snippet is taken from is_gv_magical */
1344                 const char *end = name + len;
1345                 while (--end > name) {
1346                     if (!isDIGIT(*end)) return gv;
1347                 }
1348                 goto magicalize;
1349             }
1350             }
1351         }
1352     } else {
1353         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1354            be case '\0' in this switch statement (ie a default case)  */
1355         switch (*name) {
1356         case '&':               /* $& */
1357         case '`':               /* $` */
1358         case '\'':              /* $' */
1359             if (
1360                 sv_type == SVt_PVAV ||
1361                 sv_type == SVt_PVHV ||
1362                 sv_type == SVt_PVCV ||
1363                 sv_type == SVt_PVFM ||
1364                 sv_type == SVt_PVIO
1365                 ) { break; }
1366             PL_sawampersand = TRUE;
1367             goto magicalize;
1368
1369         case ':':               /* $: */
1370             sv_setpv(GvSVn(gv),PL_chopset);
1371             goto magicalize;
1372
1373         case '?':               /* $? */
1374 #ifdef COMPLEX_STATUS
1375             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1376 #endif
1377             goto magicalize;
1378
1379         case '!':               /* $! */
1380             GvMULTI_on(gv);
1381             /* If %! has been used, automatically load Errno.pm. */
1382
1383             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1384
1385             /* magicalization must be done before require_tie_mod is called */
1386             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1387                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1388
1389             break;
1390         case '-':               /* $- */
1391         case '+':               /* $+ */
1392         GvMULTI_on(gv); /* no used once warnings here */
1393         {
1394             AV* const av = GvAVn(gv);
1395             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1396
1397             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1398             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1399             if (avc)
1400                 SvREADONLY_on(GvSVn(gv));
1401             SvREADONLY_on(av);
1402
1403             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1404                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1405
1406             break;
1407         }
1408         case '*':               /* $* */
1409         case '#':               /* $# */
1410             if (sv_type == SVt_PV)
1411                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1412                                  "$%c is no longer supported", *name);
1413             break;
1414         case '|':               /* $| */
1415             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1416             goto magicalize;
1417
1418         case '\010':    /* $^H */
1419             {
1420                 HV *const hv = GvHVn(gv);
1421                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1422             }
1423             goto magicalize;
1424         case '\023':    /* $^S */
1425         ro_magicalize:
1426             SvREADONLY_on(GvSVn(gv));
1427             /* FALL THROUGH */
1428         case '0':               /* $0 */
1429         case '1':               /* $1 */
1430         case '2':               /* $2 */
1431         case '3':               /* $3 */
1432         case '4':               /* $4 */
1433         case '5':               /* $5 */
1434         case '6':               /* $6 */
1435         case '7':               /* $7 */
1436         case '8':               /* $8 */
1437         case '9':               /* $9 */
1438         case '[':               /* $[ */
1439         case '^':               /* $^ */
1440         case '~':               /* $~ */
1441         case '=':               /* $= */
1442         case '%':               /* $% */
1443         case '.':               /* $. */
1444         case '(':               /* $( */
1445         case ')':               /* $) */
1446         case '<':               /* $< */
1447         case '>':               /* $> */
1448         case '\\':              /* $\ */
1449         case '/':               /* $/ */
1450         case '\001':    /* $^A */
1451         case '\003':    /* $^C */
1452         case '\004':    /* $^D */
1453         case '\005':    /* $^E */
1454         case '\006':    /* $^F */
1455         case '\011':    /* $^I, NOT \t in EBCDIC */
1456         case '\016':    /* $^N */
1457         case '\017':    /* $^O */
1458         case '\020':    /* $^P */
1459         case '\024':    /* $^T */
1460         case '\027':    /* $^W */
1461         magicalize:
1462             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1463             break;
1464
1465         case '\014':    /* $^L */
1466             sv_setpvs(GvSVn(gv),"\f");
1467             PL_formfeed = GvSVn(gv);
1468             break;
1469         case ';':               /* $; */
1470             sv_setpvs(GvSVn(gv),"\034");
1471             break;
1472         case ']':               /* $] */
1473         {
1474             SV * const sv = GvSVn(gv);
1475             if (!sv_derived_from(PL_patchlevel, "version"))
1476                 upg_version(PL_patchlevel, TRUE);
1477             GvSV(gv) = vnumify(PL_patchlevel);
1478             SvREADONLY_on(GvSV(gv));
1479             SvREFCNT_dec(sv);
1480         }
1481         break;
1482         case '\026':    /* $^V */
1483         {
1484             SV * const sv = GvSVn(gv);
1485             GvSV(gv) = new_version(PL_patchlevel);
1486             SvREADONLY_on(GvSV(gv));
1487             SvREFCNT_dec(sv);
1488         }
1489         break;
1490         }
1491     }
1492     return gv;
1493 }
1494
1495 void
1496 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1497 {
1498     const char *name;
1499     STRLEN namelen;
1500     const HV * const hv = GvSTASH(gv);
1501
1502     PERL_ARGS_ASSERT_GV_FULLNAME4;
1503
1504     if (!hv) {
1505         SvOK_off(sv);
1506         return;
1507     }
1508     sv_setpv(sv, prefix ? prefix : "");
1509
1510     name = HvNAME_get(hv);
1511     if (name) {
1512         namelen = HvNAMELEN_get(hv);
1513     } else {
1514         name = "__ANON__";
1515         namelen = 8;
1516     }
1517
1518     if (keepmain || strNE(name, "main")) {
1519         sv_catpvn(sv,name,namelen);
1520         sv_catpvs(sv,"::");
1521     }
1522     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1523 }
1524
1525 void
1526 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1527 {
1528     const GV * const egv = GvEGVx(gv);
1529
1530     PERL_ARGS_ASSERT_GV_EFULLNAME4;
1531
1532     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1533 }
1534
1535 void
1536 Perl_gv_check(pTHX_ const HV *stash)
1537 {
1538     dVAR;
1539     register I32 i;
1540
1541     PERL_ARGS_ASSERT_GV_CHECK;
1542
1543     if (!HvARRAY(stash))
1544         return;
1545     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1546         const HE *entry;
1547         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1548             register GV *gv;
1549             HV *hv;
1550             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1551                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
1552             {
1553                 if (hv != PL_defstash && hv != stash)
1554                      gv_check(hv);              /* nested package */
1555             }
1556             else if (isALPHA(*HeKEY(entry))) {
1557                 const char *file;
1558                 gv = MUTABLE_GV(HeVAL(entry));
1559                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1560                     continue;
1561                 file = GvFILE(gv);
1562                 CopLINE_set(PL_curcop, GvLINE(gv));
1563 #ifdef USE_ITHREADS
1564                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1565 #else
1566                 CopFILEGV(PL_curcop)
1567                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1568 #endif
1569                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1570                         "Name \"%s::%s\" used only once: possible typo",
1571                         HvNAME_get(stash), GvNAME(gv));
1572             }
1573         }
1574     }
1575 }
1576
1577 GV *
1578 Perl_newGVgen(pTHX_ const char *pack)
1579 {
1580     dVAR;
1581
1582     PERL_ARGS_ASSERT_NEWGVGEN;
1583
1584     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1585                       GV_ADD, SVt_PVGV);
1586 }
1587
1588 /* hopefully this is only called on local symbol table entries */
1589
1590 GP*
1591 Perl_gp_ref(pTHX_ GP *gp)
1592 {
1593     dVAR;
1594     if (!gp)
1595         return NULL;
1596     gp->gp_refcnt++;
1597     if (gp->gp_cv) {
1598         if (gp->gp_cvgen) {
1599             /* If the GP they asked for a reference to contains
1600                a method cache entry, clear it first, so that we
1601                don't infect them with our cached entry */
1602             SvREFCNT_dec(gp->gp_cv);
1603             gp->gp_cv = NULL;
1604             gp->gp_cvgen = 0;
1605         }
1606     }
1607     return gp;
1608 }
1609
1610 void
1611 Perl_gp_free(pTHX_ GV *gv)
1612 {
1613     dVAR;
1614     GP* gp;
1615
1616     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1617         return;
1618     if (gp->gp_refcnt == 0) {
1619         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1620                          "Attempt to free unreferenced glob pointers"
1621                          pTHX__FORMAT pTHX__VALUE);
1622         return;
1623     }
1624     if (--gp->gp_refcnt > 0) {
1625         if (gp->gp_egv == gv)
1626             gp->gp_egv = 0;
1627         GvGP(gv) = 0;
1628         return;
1629     }
1630
1631     if (gp->gp_file_hek)
1632         unshare_hek(gp->gp_file_hek);
1633     SvREFCNT_dec(gp->gp_sv);
1634     SvREFCNT_dec(gp->gp_av);
1635     /* FIXME - another reference loop GV -> symtab -> GV ?
1636        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1637     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1638         const char *hvname = HvNAME_get(gp->gp_hv);
1639         if (PL_stashcache && hvname)
1640             (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1641                       G_DISCARD);
1642         SvREFCNT_dec(gp->gp_hv);
1643     }
1644     SvREFCNT_dec(gp->gp_io);
1645     SvREFCNT_dec(gp->gp_cv);
1646     SvREFCNT_dec(gp->gp_form);
1647
1648     Safefree(gp);
1649     GvGP(gv) = 0;
1650 }
1651
1652 int
1653 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1654 {
1655     AMT * const amtp = (AMT*)mg->mg_ptr;
1656     PERL_UNUSED_ARG(sv);
1657
1658     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1659
1660     if (amtp && AMT_AMAGIC(amtp)) {
1661         int i;
1662         for (i = 1; i < NofAMmeth; i++) {
1663             CV * const cv = amtp->table[i];
1664             if (cv) {
1665                 SvREFCNT_dec(MUTABLE_SV(cv));
1666                 amtp->table[i] = NULL;
1667             }
1668         }
1669     }
1670  return 0;
1671 }
1672
1673 /* Updates and caches the CV's */
1674 /* Returns:
1675  * 1 on success and there is some overload
1676  * 0 if there is no overload
1677  * -1 if some error occurred and it couldn't croak
1678  */
1679
1680 int
1681 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
1682 {
1683   dVAR;
1684   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1685   AMT amt;
1686   const struct mro_meta* stash_meta = HvMROMETA(stash);
1687   U32 newgen;
1688
1689   PERL_ARGS_ASSERT_GV_AMUPDATE;
1690
1691   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1692   if (mg) {
1693       const AMT * const amtp = (AMT*)mg->mg_ptr;
1694       if (amtp->was_ok_am == PL_amagic_generation
1695           && amtp->was_ok_sub == newgen) {
1696           return AMT_OVERLOADED(amtp) ? 1 : 0;
1697       }
1698       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
1699   }
1700
1701   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1702
1703   Zero(&amt,1,AMT);
1704   amt.was_ok_am = PL_amagic_generation;
1705   amt.was_ok_sub = newgen;
1706   amt.fallback = AMGfallNO;
1707   amt.flags = 0;
1708
1709   {
1710     int filled = 0, have_ovl = 0;
1711     int i, lim = 1;
1712
1713     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1714
1715     /* Try to find via inheritance. */
1716     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1717     SV * const sv = gv ? GvSV(gv) : NULL;
1718     CV* cv;
1719
1720     if (!gv)
1721         lim = DESTROY_amg;              /* Skip overloading entries. */
1722 #ifdef PERL_DONT_CREATE_GVSV
1723     else if (!sv) {
1724         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1725     }
1726 #endif
1727     else if (SvTRUE(sv))
1728         amt.fallback=AMGfallYES;
1729     else if (SvOK(sv))
1730         amt.fallback=AMGfallNEVER;
1731
1732     for (i = 1; i < lim; i++)
1733         amt.table[i] = NULL;
1734     for (; i < NofAMmeth; i++) {
1735         const char * const cooky = PL_AMG_names[i];
1736         /* Human-readable form, for debugging: */
1737         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1738         const STRLEN l = PL_AMG_namelens[i];
1739
1740         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1741                      cp, HvNAME_get(stash)) );
1742         /* don't fill the cache while looking up!
1743            Creation of inheritance stubs in intermediate packages may
1744            conflict with the logic of runtime method substitution.
1745            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1746            then we could have created stubs for "(+0" in A and C too.
1747            But if B overloads "bool", we may want to use it for
1748            numifying instead of C's "+0". */
1749         if (i >= DESTROY_amg)
1750             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1751         else                            /* Autoload taken care of below */
1752             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1753         cv = 0;
1754         if (gv && (cv = GvCV(gv))) {
1755             const char *hvname;
1756             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1757                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1758                 /* This is a hack to support autoloading..., while
1759                    knowing *which* methods were declared as overloaded. */
1760                 /* GvSV contains the name of the method. */
1761                 GV *ngv = NULL;
1762                 SV *gvsv = GvSV(gv);
1763
1764                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1765                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1766                              (void*)GvSV(gv), cp, hvname) );
1767                 if (!gvsv || !SvPOK(gvsv)
1768                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1769                                                        FALSE)))
1770                 {
1771                     /* Can be an import stub (created by "can"). */
1772                     if (destructing) {
1773                         return -1;
1774                     }
1775                     else {
1776                         const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1777                         Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1778                                     "in package \"%.256s\"",
1779                                    (GvCVGEN(gv) ? "Stub found while resolving"
1780                                     : "Can't resolve"),
1781                                    name, cp, hvname);
1782                     }
1783                 }
1784                 cv = GvCV(gv = ngv);
1785             }
1786             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1787                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1788                          GvNAME(CvGV(cv))) );
1789             filled = 1;
1790             if (i < DESTROY_amg)
1791                 have_ovl = 1;
1792         } else if (gv) {                /* Autoloaded... */
1793             cv = MUTABLE_CV(gv);
1794             filled = 1;
1795         }
1796         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
1797     }
1798     if (filled) {
1799       AMT_AMAGIC_on(&amt);
1800       if (have_ovl)
1801           AMT_OVERLOADED_on(&amt);
1802       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
1803                                                 (char*)&amt, sizeof(AMT));
1804       return have_ovl;
1805     }
1806   }
1807   /* Here we have no table: */
1808   /* no_table: */
1809   AMT_AMAGIC_off(&amt);
1810   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
1811                                                 (char*)&amt, sizeof(AMTS));
1812   return 0;
1813 }
1814
1815
1816 CV*
1817 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1818 {
1819     dVAR;
1820     MAGIC *mg;
1821     AMT *amtp;
1822     U32 newgen;
1823     struct mro_meta* stash_meta;
1824
1825     if (!stash || !HvNAME_get(stash))
1826         return NULL;
1827
1828     stash_meta = HvMROMETA(stash);
1829     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1830
1831     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1832     if (!mg) {
1833       do_update:
1834         /* If we're looking up a destructor to invoke, we must avoid
1835          * that Gv_AMupdate croaks, because we might be dying already */
1836         if (Gv_AMupdate(stash, id == DESTROY_amg) == -1) {
1837             /* and if it didn't found a destructor, we fall back
1838              * to a simpler method that will only look for the
1839              * destructor instead of the whole magic */
1840             if (id == DESTROY_amg) {
1841                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
1842                 if (gv)
1843                     return GvCV(gv);
1844             }
1845             return NULL;
1846         }
1847         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1848     }
1849     assert(mg);
1850     amtp = (AMT*)mg->mg_ptr;
1851     if ( amtp->was_ok_am != PL_amagic_generation
1852          || amtp->was_ok_sub != newgen )
1853         goto do_update;
1854     if (AMT_AMAGIC(amtp)) {
1855         CV * const ret = amtp->table[id];
1856         if (ret && isGV(ret)) {         /* Autoloading stab */
1857             /* Passing it through may have resulted in a warning
1858                "Inherited AUTOLOAD for a non-method deprecated", since
1859                our caller is going through a function call, not a method call.
1860                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1861             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1862
1863             if (gv && GvCV(gv))
1864                 return GvCV(gv);
1865         }
1866         return ret;
1867     }
1868
1869     return NULL;
1870 }
1871
1872
1873 /* Implement tryAMAGICun_MG macro.
1874    Do get magic, then see if the stack arg is overloaded and if so call it.
1875    Flags:
1876         AMGf_set     return the arg using SETs rather than assigning to
1877                      the targ
1878         AMGf_numeric apply sv_2num to the stack arg.
1879 */
1880
1881 bool
1882 Perl_try_amagic_un(pTHX_ int method, int flags) {
1883     dVAR;
1884     dSP;
1885     SV* tmpsv;
1886     SV* const arg = TOPs;
1887
1888     SvGETMAGIC(arg);
1889
1890     if (SvAMAGIC(arg) && (tmpsv = AMG_CALLun_var(arg,method))) {
1891         if (flags & AMGf_set) {
1892             SETs(tmpsv);
1893         }
1894         else {
1895             dTARGET;
1896             if (SvPADMY(TARG)) {
1897                 sv_setsv(TARG, tmpsv);
1898                 SETTARG;
1899             }
1900             else
1901                 SETs(tmpsv);
1902         }
1903         PUTBACK;
1904         return TRUE;
1905     }
1906
1907     if ((flags & AMGf_numeric) && SvROK(arg))
1908         *sp = sv_2num(arg);
1909     return FALSE;
1910 }
1911
1912
1913 /* Implement tryAMAGICbin_MG macro.
1914    Do get magic, then see if the two stack args are overloaded and if so
1915    call it.
1916    Flags:
1917         AMGf_set     return the arg using SETs rather than assigning to
1918                      the targ
1919         AMGf_assign  op may be called as mutator (eg +=)
1920         AMGf_numeric apply sv_2num to the stack arg.
1921 */
1922
1923 bool
1924 Perl_try_amagic_bin(pTHX_ int method, int flags) {
1925     dVAR;
1926     dSP;
1927     SV* const left = TOPm1s;
1928     SV* const right = TOPs;
1929
1930     SvGETMAGIC(left);
1931     if (left != right)
1932         SvGETMAGIC(right);
1933
1934     if (SvAMAGIC(left) || SvAMAGIC(right)) {
1935         SV * const tmpsv = amagic_call(left, right, method,
1936                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
1937         if (tmpsv) {
1938             if (flags & AMGf_set) {
1939                 (void)POPs;
1940                 SETs(tmpsv);
1941             }
1942             else {
1943                 dATARGET;
1944                 (void)POPs;
1945                 if (opASSIGN || SvPADMY(TARG)) {
1946                     sv_setsv(TARG, tmpsv);
1947                     SETTARG;
1948                 }
1949                 else
1950                     SETs(tmpsv);
1951             }
1952             PUTBACK;
1953             return TRUE;
1954         }
1955     }
1956     if (flags & AMGf_numeric) {
1957         if (SvROK(left))
1958             *(sp-1) = sv_2num(left);
1959         if (SvROK(right))
1960             *sp     = sv_2num(right);
1961     }
1962     return FALSE;
1963 }
1964
1965
1966 SV*
1967 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1968 {
1969   dVAR;
1970   MAGIC *mg;
1971   CV *cv=NULL;
1972   CV **cvp=NULL, **ocvp=NULL;
1973   AMT *amtp=NULL, *oamtp=NULL;
1974   int off = 0, off1, lr = 0, notfound = 0;
1975   int postpr = 0, force_cpy = 0;
1976   int assign = AMGf_assign & flags;
1977   const int assignshift = assign ? 1 : 0;
1978 #ifdef DEBUGGING
1979   int fl=0;
1980 #endif
1981   HV* stash=NULL;
1982
1983   PERL_ARGS_ASSERT_AMAGIC_CALL;
1984
1985   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
1986       SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
1987                                               0, "overloading", 11, 0, 0);
1988
1989       if ( !lex_mask || !SvOK(lex_mask) )
1990           /* overloading lexically disabled */
1991           return NULL;
1992       else if ( lex_mask && SvPOK(lex_mask) ) {
1993           /* we have an entry in the hints hash, check if method has been
1994            * masked by overloading.pm */
1995           STRLEN len;
1996           const int offset = method / 8;
1997           const int bit    = method % 8;
1998           char *pv = SvPV(lex_mask, len);
1999
2000           /* Bit set, so this overloading operator is disabled */
2001           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2002               return NULL;
2003       }
2004   }
2005
2006   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2007       && (stash = SvSTASH(SvRV(left)))
2008       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2009       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2010                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2011                         : NULL))
2012       && ((cv = cvp[off=method+assignshift])
2013           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2014                                                           * usual method */
2015                   (
2016 #ifdef DEBUGGING
2017                    fl = 1,
2018 #endif
2019                    cv = cvp[off=method])))) {
2020     lr = -1;                    /* Call method for left argument */
2021   } else {
2022     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2023       int logic;
2024
2025       /* look for substituted methods */
2026       /* In all the covered cases we should be called with assign==0. */
2027          switch (method) {
2028          case inc_amg:
2029            force_cpy = 1;
2030            if ((cv = cvp[off=add_ass_amg])
2031                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2032              right = &PL_sv_yes; lr = -1; assign = 1;
2033            }
2034            break;
2035          case dec_amg:
2036            force_cpy = 1;
2037            if ((cv = cvp[off = subtr_ass_amg])
2038                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2039              right = &PL_sv_yes; lr = -1; assign = 1;
2040            }
2041            break;
2042          case bool__amg:
2043            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2044            break;
2045          case numer_amg:
2046            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2047            break;
2048          case string_amg:
2049            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2050            break;
2051          case not_amg:
2052            (void)((cv = cvp[off=bool__amg])
2053                   || (cv = cvp[off=numer_amg])
2054                   || (cv = cvp[off=string_amg]));
2055            if (cv)
2056                postpr = 1;
2057            break;
2058          case copy_amg:
2059            {
2060              /*
2061                   * SV* ref causes confusion with the interpreter variable of
2062                   * the same name
2063                   */
2064              SV* const tmpRef=SvRV(left);
2065              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2066                 /*
2067                  * Just to be extra cautious.  Maybe in some
2068                  * additional cases sv_setsv is safe, too.
2069                  */
2070                 SV* const newref = newSVsv(tmpRef);
2071                 SvOBJECT_on(newref);
2072                 /* As a bit of a source compatibility hack, SvAMAGIC() and
2073                    friends dereference an RV, to behave the same was as when
2074                    overloading was stored on the reference, not the referant.
2075                    Hence we can't use SvAMAGIC_on()
2076                 */
2077                 SvFLAGS(newref) |= SVf_AMAGIC;
2078                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2079                 return newref;
2080              }
2081            }
2082            break;
2083          case abs_amg:
2084            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2085                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2086              SV* const nullsv=sv_2mortal(newSViv(0));
2087              if (off1==lt_amg) {
2088                SV* const lessp = amagic_call(left,nullsv,
2089                                        lt_amg,AMGf_noright);
2090                logic = SvTRUE(lessp);
2091              } else {
2092                SV* const lessp = amagic_call(left,nullsv,
2093                                        ncmp_amg,AMGf_noright);
2094                logic = (SvNV(lessp) < 0);
2095              }
2096              if (logic) {
2097                if (off==subtr_amg) {
2098                  right = left;
2099                  left = nullsv;
2100                  lr = 1;
2101                }
2102              } else {
2103                return left;
2104              }
2105            }
2106            break;
2107          case neg_amg:
2108            if ((cv = cvp[off=subtr_amg])) {
2109              right = left;
2110              left = sv_2mortal(newSViv(0));
2111              lr = 1;
2112            }
2113            break;
2114          case int_amg:
2115          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2116          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2117          case regexp_amg:
2118              /* FAIL safe */
2119              return NULL;       /* Delegate operation to standard mechanisms. */
2120              break;
2121          case to_sv_amg:
2122          case to_av_amg:
2123          case to_hv_amg:
2124          case to_gv_amg:
2125          case to_cv_amg:
2126              /* FAIL safe */
2127              return left;       /* Delegate operation to standard mechanisms. */
2128              break;
2129          default:
2130            goto not_found;
2131          }
2132          if (!cv) goto not_found;
2133     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2134                && (stash = SvSTASH(SvRV(right)))
2135                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2136                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2137                           ? (amtp = (AMT*)mg->mg_ptr)->table
2138                           : NULL))
2139                && (cv = cvp[off=method])) { /* Method for right
2140                                              * argument found */
2141       lr=1;
2142     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
2143                  && (cvp=ocvp) && (lr = -1))
2144                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
2145                && !(flags & AMGf_unary)) {
2146                                 /* We look for substitution for
2147                                  * comparison operations and
2148                                  * concatenation */
2149       if (method==concat_amg || method==concat_ass_amg
2150           || method==repeat_amg || method==repeat_ass_amg) {
2151         return NULL;            /* Delegate operation to string conversion */
2152       }
2153       off = -1;
2154       switch (method) {
2155          case lt_amg:
2156          case le_amg:
2157          case gt_amg:
2158          case ge_amg:
2159          case eq_amg:
2160          case ne_amg:
2161              off = ncmp_amg;
2162              break;
2163          case slt_amg:
2164          case sle_amg:
2165          case sgt_amg:
2166          case sge_amg:
2167          case seq_amg:
2168          case sne_amg:
2169              off = scmp_amg;
2170              break;
2171          }
2172       if ((off != -1) && (cv = cvp[off]))
2173           postpr = 1;
2174       else
2175           goto not_found;
2176     } else {
2177     not_found:                  /* No method found, either report or croak */
2178       switch (method) {
2179          case to_sv_amg:
2180          case to_av_amg:
2181          case to_hv_amg:
2182          case to_gv_amg:
2183          case to_cv_amg:
2184              /* FAIL safe */
2185              return left;       /* Delegate operation to standard mechanisms. */
2186              break;
2187       }
2188       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2189         notfound = 1; lr = -1;
2190       } else if (cvp && (cv=cvp[nomethod_amg])) {
2191         notfound = 1; lr = 1;
2192       } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
2193         /* Skip generating the "no method found" message.  */
2194         return NULL;
2195       } else {
2196         SV *msg;
2197         if (off==-1) off=method;
2198         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2199                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
2200                       AMG_id2name(method + assignshift),
2201                       (flags & AMGf_unary ? " " : "\n\tleft "),
2202                       SvAMAGIC(left)?
2203                         "in overloaded package ":
2204                         "has no overloaded magic",
2205                       SvAMAGIC(left)?
2206                         HvNAME_get(SvSTASH(SvRV(left))):
2207                         "",
2208                       SvAMAGIC(right)?
2209                         ",\n\tright argument in overloaded package ":
2210                         (flags & AMGf_unary
2211                          ? ""
2212                          : ",\n\tright argument has no overloaded magic"),
2213                       SvAMAGIC(right)?
2214                         HvNAME_get(SvSTASH(SvRV(right))):
2215                         ""));
2216         if (amtp && amtp->fallback >= AMGfallYES) {
2217           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2218         } else {
2219           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2220         }
2221         return NULL;
2222       }
2223       force_cpy = force_cpy || assign;
2224     }
2225   }
2226 #ifdef DEBUGGING
2227   if (!notfound) {
2228     DEBUG_o(Perl_deb(aTHX_
2229                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2230                      AMG_id2name(off),
2231                      method+assignshift==off? "" :
2232                      " (initially \"",
2233                      method+assignshift==off? "" :
2234                      AMG_id2name(method+assignshift),
2235                      method+assignshift==off? "" : "\")",
2236                      flags & AMGf_unary? "" :
2237                      lr==1 ? " for right argument": " for left argument",
2238                      flags & AMGf_unary? " for argument" : "",
2239                      stash ? HvNAME_get(stash) : "null",
2240                      fl? ",\n\tassignment variant used": "") );
2241   }
2242 #endif
2243     /* Since we use shallow copy during assignment, we need
2244      * to dublicate the contents, probably calling user-supplied
2245      * version of copy operator
2246      */
2247     /* We need to copy in following cases:
2248      * a) Assignment form was called.
2249      *          assignshift==1,  assign==T, method + 1 == off
2250      * b) Increment or decrement, called directly.
2251      *          assignshift==0,  assign==0, method + 0 == off
2252      * c) Increment or decrement, translated to assignment add/subtr.
2253      *          assignshift==0,  assign==T,
2254      *          force_cpy == T
2255      * d) Increment or decrement, translated to nomethod.
2256      *          assignshift==0,  assign==0,
2257      *          force_cpy == T
2258      * e) Assignment form translated to nomethod.
2259      *          assignshift==1,  assign==T, method + 1 != off
2260      *          force_cpy == T
2261      */
2262     /*  off is method, method+assignshift, or a result of opcode substitution.
2263      *  In the latter case assignshift==0, so only notfound case is important.
2264      */
2265   if (( (method + assignshift == off)
2266         && (assign || (method == inc_amg) || (method == dec_amg)))
2267       || force_cpy)
2268   {
2269     RvDEEPCP(left);
2270   }
2271
2272   {
2273     dSP;
2274     BINOP myop;
2275     SV* res;
2276     const bool oldcatch = CATCH_GET;
2277
2278     CATCH_SET(TRUE);
2279     Zero(&myop, 1, BINOP);
2280     myop.op_last = (OP *) &myop;
2281     myop.op_next = NULL;
2282     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2283
2284     PUSHSTACKi(PERLSI_OVERLOAD);
2285     ENTER;
2286     SAVEOP();
2287     PL_op = (OP *) &myop;
2288     if (PERLDB_SUB && PL_curstash != PL_debstash)
2289         PL_op->op_private |= OPpENTERSUB_DB;
2290     PUTBACK;
2291     pp_pushmark();
2292
2293     EXTEND(SP, notfound + 5);
2294     PUSHs(lr>0? right: left);
2295     PUSHs(lr>0? left: right);
2296     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2297     if (notfound) {
2298       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2299                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2300     }
2301     PUSHs(MUTABLE_SV(cv));
2302     PUTBACK;
2303
2304     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2305       CALLRUNOPS(aTHX);
2306     LEAVE;
2307     SPAGAIN;
2308
2309     res=POPs;
2310     PUTBACK;
2311     POPSTACK;
2312     CATCH_SET(oldcatch);
2313
2314     if (postpr) {
2315       int ans;
2316       switch (method) {
2317       case le_amg:
2318       case sle_amg:
2319         ans=SvIV(res)<=0; break;
2320       case lt_amg:
2321       case slt_amg:
2322         ans=SvIV(res)<0; break;
2323       case ge_amg:
2324       case sge_amg:
2325         ans=SvIV(res)>=0; break;
2326       case gt_amg:
2327       case sgt_amg:
2328         ans=SvIV(res)>0; break;
2329       case eq_amg:
2330       case seq_amg:
2331         ans=SvIV(res)==0; break;
2332       case ne_amg:
2333       case sne_amg:
2334         ans=SvIV(res)!=0; break;
2335       case inc_amg:
2336       case dec_amg:
2337         SvSetSV(left,res); return left;
2338       case not_amg:
2339         ans=!SvTRUE(res); break;
2340       default:
2341         ans=0; break;
2342       }
2343       return boolSV(ans);
2344     } else if (method==copy_amg) {
2345       if (!SvROK(res)) {
2346         Perl_croak(aTHX_ "Copy method did not return a reference");
2347       }
2348       return SvREFCNT_inc(SvRV(res));
2349     } else {
2350       return res;
2351     }
2352   }
2353 }
2354
2355 /*
2356 =for apidoc is_gv_magical_sv
2357
2358 Returns C<TRUE> if given the name of a magical GV.
2359
2360 Currently only useful internally when determining if a GV should be
2361 created even in rvalue contexts.
2362
2363 C<flags> is not used at present but available for future extension to
2364 allow selecting particular classes of magical variable.
2365
2366 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2367 This assumption is met by all callers within the perl core, which all pass
2368 pointers returned by SvPV.
2369
2370 =cut
2371 */
2372
2373 bool
2374 Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
2375 {
2376     STRLEN len;
2377     const char *const name = SvPV_const(name_sv, len);
2378
2379     PERL_UNUSED_ARG(flags);
2380     PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
2381
2382     if (len > 1) {
2383         const char * const name1 = name + 1;
2384         switch (*name) {
2385         case 'I':
2386             if (len == 3 && name[1] == 'S' && name[2] == 'A')
2387                 goto yes;
2388             break;
2389         case 'O':
2390             if (len == 8 && strEQ(name1, "VERLOAD"))
2391                 goto yes;
2392             break;
2393         case 'S':
2394             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2395                 goto yes;
2396             break;
2397             /* Using ${^...} variables is likely to be sufficiently rare that
2398                it seems sensible to avoid the space hit of also checking the
2399                length.  */
2400         case '\017':   /* ${^OPEN} */
2401             if (strEQ(name1, "PEN"))
2402                 goto yes;
2403             break;
2404         case '\024':   /* ${^TAINT} */
2405             if (strEQ(name1, "AINT"))
2406                 goto yes;
2407             break;
2408         case '\025':    /* ${^UNICODE} */
2409             if (strEQ(name1, "NICODE"))
2410                 goto yes;
2411             if (strEQ(name1, "TF8LOCALE"))
2412                 goto yes;
2413             break;
2414         case '\027':   /* ${^WARNING_BITS} */
2415             if (strEQ(name1, "ARNING_BITS"))
2416                 goto yes;
2417             break;
2418         case '1':
2419         case '2':
2420         case '3':
2421         case '4':
2422         case '5':
2423         case '6':
2424         case '7':
2425         case '8':
2426         case '9':
2427         {
2428             const char *end = name + len;
2429             while (--end > name) {
2430                 if (!isDIGIT(*end))
2431                     return FALSE;
2432             }
2433             goto yes;
2434         }
2435         }
2436     } else {
2437         /* Because we're already assuming that name is NUL terminated
2438            below, we can treat an empty name as "\0"  */
2439         switch (*name) {
2440         case '&':
2441         case '`':
2442         case '\'':
2443         case ':':
2444         case '?':
2445         case '!':
2446         case '-':
2447         case '#':
2448         case '[':
2449         case '^':
2450         case '~':
2451         case '=':
2452         case '%':
2453         case '.':
2454         case '(':
2455         case ')':
2456         case '<':
2457         case '>':
2458         case '\\':
2459         case '/':
2460         case '|':
2461         case '+':
2462         case ';':
2463         case ']':
2464         case '\001':   /* $^A */
2465         case '\003':   /* $^C */
2466         case '\004':   /* $^D */
2467         case '\005':   /* $^E */
2468         case '\006':   /* $^F */
2469         case '\010':   /* $^H */
2470         case '\011':   /* $^I, NOT \t in EBCDIC */
2471         case '\014':   /* $^L */
2472         case '\016':   /* $^N */
2473         case '\017':   /* $^O */
2474         case '\020':   /* $^P */
2475         case '\023':   /* $^S */
2476         case '\024':   /* $^T */
2477         case '\026':   /* $^V */
2478         case '\027':   /* $^W */
2479         case '1':
2480         case '2':
2481         case '3':
2482         case '4':
2483         case '5':
2484         case '6':
2485         case '7':
2486         case '8':
2487         case '9':
2488         yes:
2489             return TRUE;
2490         default:
2491             break;
2492         }
2493     }
2494     return FALSE;
2495 }
2496
2497 void
2498 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2499 {
2500     dVAR;
2501     U32 hash;
2502
2503     PERL_ARGS_ASSERT_GV_NAME_SET;
2504     PERL_UNUSED_ARG(flags);
2505
2506     if (len > I32_MAX)
2507         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2508
2509     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2510         unshare_hek(GvNAME_HEK(gv));
2511     }
2512
2513     PERL_HASH(hash, name, len);
2514     GvNAME_HEK(gv) = share_hek(name, len, hash);
2515 }
2516
2517 /*
2518 =for apidoc gv_try_downgrade
2519
2520 If the typeglob C<gv> can be expressed more succinctly, by having
2521 something other than a real GV in its place in the stash, replace it
2522 with the optimised form.  Basic requirements for this are that C<gv>
2523 is a real typeglob, is sufficiently ordinary, and is only referenced
2524 from its package.  This function is meant to be used when a GV has been
2525 looked up in part to see what was there, causing upgrading, but based
2526 on what was found it turns out that the real GV isn't required after all.
2527
2528 If C<gv> is a completely empty typeglob, it is deleted from the stash.
2529
2530 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2531 sub, the typeglob is replaced with a scalar-reference placeholder that
2532 more compactly represents the same thing.
2533
2534 =cut
2535 */
2536
2537 void
2538 Perl_gv_try_downgrade(pTHX_ GV *gv)
2539 {
2540     HV *stash;
2541     CV *cv;
2542     HEK *namehek;
2543     SV **gvp;
2544     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
2545     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
2546             !SvOBJECT(gv) && !SvREADONLY(gv) &&
2547             isGV_with_GP(gv) && GvGP(gv) &&
2548             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
2549             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
2550             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2551         return;
2552     if (SvMAGICAL(gv)) {
2553         MAGIC *mg;
2554         /* only backref magic is allowed */
2555         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
2556             return;
2557         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
2558             if (mg->mg_type != PERL_MAGIC_backref)
2559                 return;
2560         }
2561     }
2562     cv = GvCV(gv);
2563     if (!cv) {
2564         HEK *gvnhek = GvNAME_HEK(gv);
2565         (void)hv_delete(stash, HEK_KEY(gvnhek),
2566             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
2567     } else if (GvMULTI(gv) && cv &&
2568             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
2569             CvSTASH(cv) == stash && CvGV(cv) == gv &&
2570             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
2571             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
2572             (namehek = GvNAME_HEK(gv)) &&
2573             (gvp = hv_fetch(stash, HEK_KEY(namehek),
2574                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
2575             *gvp == (SV*)gv) {
2576         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
2577         SvREFCNT(gv) = 0;
2578         sv_clear((SV*)gv);
2579         SvREFCNT(gv) = 1;
2580         SvFLAGS(gv) = SVt_IV|SVf_ROK;
2581         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
2582                                 STRUCT_OFFSET(XPVIV, xiv_iv));
2583         SvRV_set(gv, value);
2584     }
2585 }
2586
2587 /*
2588  * Local variables:
2589  * c-indentation-style: bsd
2590  * c-basic-offset: 4
2591  * indent-tabs-mode: t
2592  * End:
2593  *
2594  * ex: set ts=8 sts=4 sw=4 noet:
2595  */