gv.c

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