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