gv.c

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