gv.c

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