gv.c

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