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 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
  25 It is a structure that holds a pointer to a scalar, an array, a hash etc,
  26 corresponding to $foo, @foo, %foo.
  27
  28 GVs are usually found as values in stashes (symbol table hashes) where
  29 Perl stores its global variables.
  30
  31 =cut
  32 */
  33
  34 #include "EXTERN.h"
  35 #define PERL_IN_GV_C
  36 #include "perl.h"
  37 #include "overload.c"
  38 #include "keywords.h"
  39 #include "feature.h"
  40
  41 static const char S_autoload[] = "AUTOLOAD";
  42 static const STRLEN S_autolen = sizeof(S_autoload)-1;
  43
  44 GV *
  45 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
  46 {
  47     SV **where;
  48
  49     if (
  50         !gv
  51      || (
  52             SvTYPE((const SV *)gv) != SVt_PVGV
  53          && SvTYPE((const SV *)gv) != SVt_PVLV
  54         )
  55     ) {
  56         const char *what;
  57         if (type == SVt_PVIO) {
  58             /*
  59              * if it walks like a dirhandle, then let's assume that
  60              * this is a dirhandle.
  61              */
  62             what = OP_IS_DIRHOP(PL_op->op_type) ?
  63                 "dirhandle" : "filehandle";
  64         } else if (type == SVt_PVHV) {
  65             what = "hash";
  66         } else {
  67             what = type == SVt_PVAV ? "array" : "scalar";
  68         }
  69         /* diag_listed_as: Bad symbol for filehandle */
  70         Perl_croak(aTHX_ "Bad symbol for %s", what);
  71     }
  72
  73     if (type == SVt_PVHV) {
  74         where = (SV **)&GvHV(gv);
  75     } else if (type == SVt_PVAV) {
  76         where = (SV **)&GvAV(gv);
  77     } else if (type == SVt_PVIO) {
  78         where = (SV **)&GvIOp(gv);
  79     } else {
  80         where = &GvSV(gv);
  81     }
  82
  83     if (!*where)
  84     {
  85         *where = newSV_type(type);
  86             if (type == SVt_PVAV && GvNAMELEN(gv) == 3
  87              && strnEQ(GvNAME(gv), "ISA", 3))
  88             sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
  89     }
  90     return gv;
  91 }
  92
  93 GV *
  94 Perl_gv_fetchfile(pTHX_ const char *name)
  95 {
  96     PERL_ARGS_ASSERT_GV_FETCHFILE;
  97     return gv_fetchfile_flags(name, strlen(name), 0);
  98 }
  99
 100 GV *
 101 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
 102                         const U32 flags)
 103 {
 104     char smallbuf[128];
 105     char *tmpbuf;
 106     const STRLEN tmplen = namelen + 2;
 107     GV *gv;
 108
 109     PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
 110     PERL_UNUSED_ARG(flags);
 111
 112     if (!PL_defstash)
 113         return NULL;
 114
 115     if (tmplen <= sizeof smallbuf)
 116         tmpbuf = smallbuf;
 117     else
 118         Newx(tmpbuf, tmplen, char);
 119     /* This is where the debugger's %{"::_<$filename"} hash is created */
 120     tmpbuf[0] = '_';
 121     tmpbuf[1] = '<';
 122     memcpy(tmpbuf + 2, name, namelen);
 123     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
 124     if (!isGV(gv)) {
 125         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
 126 #ifdef PERL_DONT_CREATE_GVSV
 127         GvSV(gv) = newSVpvn(name, namelen);
 128 #else
 129         sv_setpvn(GvSV(gv), name, namelen);
 130 #endif
 131     }
 132     if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
 133             hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
 134     if (tmpbuf != smallbuf)
 135         Safefree(tmpbuf);
 136     return gv;
 137 }
 138
 139 /*
 140 =for apidoc gv_const_sv
 141
 142 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
 143 inlining, or C<gv> is a placeholder reference that would be promoted to such
 144 a typeglob, then returns the value returned by the sub.  Otherwise, returns
 145 NULL.
 146
 147 =cut
 148 */
 149
 150 SV *
 151 Perl_gv_const_sv(pTHX_ GV *gv)
 152 {
 153     PERL_ARGS_ASSERT_GV_CONST_SV;
 154     PERL_UNUSED_CONTEXT;
 155
 156     if (SvTYPE(gv) == SVt_PVGV)
 157         return cv_const_sv(GvCVu(gv));
 158     return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL;
 159 }
 160
 161 GP *
 162 Perl_newGP(pTHX_ GV *const gv)
 163 {
 164     GP *gp;
 165     U32 hash;
 166     const char *file;
 167     STRLEN len;
 168 #ifndef USE_ITHREADS
 169     GV *filegv;
 170 #endif
 171     dVAR;
 172
 173     PERL_ARGS_ASSERT_NEWGP;
 174     Newxz(gp, 1, GP);
 175     gp->gp_egv = gv; /* allow compiler to reuse gv after this */
 176 #ifndef PERL_DONT_CREATE_GVSV
 177     gp->gp_sv = newSV(0);
 178 #endif
 179
 180     /* PL_curcop may be null here.  E.g.,
 181         INIT { bless {} and exit }
 182        frees INIT before looking up DESTROY (and creating *DESTROY)
 183     */
 184     if (PL_curcop) {
 185         gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
 186 #ifdef USE_ITHREADS
 187         if (CopFILE(PL_curcop)) {
 188             file = CopFILE(PL_curcop);
 189             len = strlen(file);
 190         }
 191 #else
 192         filegv = CopFILEGV(PL_curcop);
 193         if (filegv) {
 194             file = GvNAME(filegv)+2;
 195             len = GvNAMELEN(filegv)-2;
 196         }
 197 #endif
 198         else goto no_file;
 199     }
 200     else {
 201         no_file:
 202         file = "";
 203         len = 0;
 204     }
 205
 206     PERL_HASH(hash, file, len);
 207     gp->gp_file_hek = share_hek(file, len, hash);
 208     gp->gp_refcnt = 1;
 209
 210     return gp;
 211 }
 212
 213 /* Assign CvGV(cv) = gv, handling weak references.
 214  * See also S_anonymise_cv_maybe */
 215
 216 void
 217 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
 218 {
 219     GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
 220     HEK *hek;
 221     PERL_ARGS_ASSERT_CVGV_SET;
 222
 223     if (oldgv == gv)
 224         return;
 225
 226     if (oldgv) {
 227         if (CvCVGV_RC(cv)) {
 228             SvREFCNT_dec_NN(oldgv);
 229             CvCVGV_RC_off(cv);
 230         }
 231         else {
 232             sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
 233         }
 234     }
 235     else if ((hek = CvNAME_HEK(cv))) {
 236         unshare_hek(hek);
 237         CvLEXICAL_off(cv);
 238     }
 239
 240     CvNAMED_off(cv);
 241     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
 242     assert(!CvCVGV_RC(cv));
 243
 244     if (!gv)
 245         return;
 246
 247     if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
 248         Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
 249     else {
 250         CvCVGV_RC_on(cv);
 251         SvREFCNT_inc_simple_void_NN(gv);
 252     }
 253 }
 254
 255 /* Convert CvSTASH + CvNAME_HEK into a GV.  Conceptually, all subs have a
 256    GV, but for efficiency that GV may not in fact exist.  This function,
 257    called by CvGV, reifies it. */
 258
 259 GV *
 260 Perl_cvgv_from_hek(pTHX_ CV *cv)
 261 {
 262     GV *gv;
 263     SV **svp;
 264     PERL_ARGS_ASSERT_CVGV_FROM_HEK;
 265     assert(SvTYPE(cv) == SVt_PVCV);
 266     if (!CvSTASH(cv)) return NULL;
 267     ASSUME(CvNAME_HEK(cv));
 268     svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
 269     gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
 270     if (!isGV(gv))
 271         gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
 272                 HEK_LEN(CvNAME_HEK(cv)),
 273                 SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
 274     if (!CvNAMED(cv)) { /* gv_init took care of it */
 275         assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
 276         return gv;
 277     }
 278     unshare_hek(CvNAME_HEK(cv));
 279     CvNAMED_off(cv);
 280     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
 281     if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
 282     CvCVGV_RC_on(cv);
 283     return gv;
 284 }
 285
 286 /* Assign CvSTASH(cv) = st, handling weak references. */
 287
 288 void
 289 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
 290 {
 291     HV *oldst = CvSTASH(cv);
 292     PERL_ARGS_ASSERT_CVSTASH_SET;
 293     if (oldst == st)
 294         return;
 295     if (oldst)
 296         sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
 297     SvANY(cv)->xcv_stash = st;
 298     if (st)
 299         Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
 300 }
 301
 302 /*
 303 =for apidoc gv_init_pvn
 304
 305 Converts a scalar into a typeglob.  This is an incoercible typeglob;
 306 assigning a reference to it will assign to one of its slots, instead of
 307 overwriting it as happens with typeglobs created by SvSetSV.  Converting
 308 any scalar that is SvOK() may produce unpredictable results and is reserved
 309 for perl's internal use.
 310
 311 C<gv> is the scalar to be converted.
 312
 313 C<stash> is the parent stash/package, if any.
 314
 315 C<name> and C<len> give the name.  The name must be unqualified;
 316 that is, it must not include the package name.  If C<gv> is a
 317 stash element, it is the caller's responsibility to ensure that the name
 318 passed to this function matches the name of the element.  If it does not
 319 match, perl's internal bookkeeping will get out of sync.
 320
 321 C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
 322 the return value of SvUTF8(sv).  It can also take the
 323 GV_ADDMULTI flag, which means to pretend that the GV has been
 324 seen before (i.e., suppress "Used once" warnings).
 325
 326 =for apidoc gv_init
 327
 328 The old form of gv_init_pvn().  It does not work with UTF8 strings, as it
 329 has no flags parameter.  If the C<multi> parameter is set, the
 330 GV_ADDMULTI flag will be passed to gv_init_pvn().
 331
 332 =for apidoc gv_init_pv
 333
 334 Same as gv_init_pvn(), but takes a nul-terminated string for the name
 335 instead of separate char * and length parameters.
 336
 337 =for apidoc gv_init_sv
 338
 339 Same as gv_init_pvn(), but takes an SV * for the name instead of separate
 340 char * and length parameters.  C<flags> is currently unused.
 341
 342 =cut
 343 */
 344
 345 void
 346 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
 347 {
 348    char *namepv;
 349    STRLEN namelen;
 350    PERL_ARGS_ASSERT_GV_INIT_SV;
 351    namepv = SvPV(namesv, namelen);
 352    if (SvUTF8(namesv))
 353        flags |= SVf_UTF8;
 354    gv_init_pvn(gv, stash, namepv, namelen, flags);
 355 }
 356
 357 void
 358 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
 359 {
 360    PERL_ARGS_ASSERT_GV_INIT_PV;
 361    gv_init_pvn(gv, stash, name, strlen(name), flags);
 362 }
 363
 364 void
 365 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
 366 {
 367     const U32 old_type = SvTYPE(gv);
 368     const bool doproto = old_type > SVt_NULL;
 369     char * const proto = (doproto && SvPOK(gv))
 370         ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
 371         : NULL;
 372     const STRLEN protolen = proto ? SvCUR(gv) : 0;
 373     const U32 proto_utf8  = proto ? SvUTF8(gv) : 0;
 374     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
 375     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
 376
 377     PERL_ARGS_ASSERT_GV_INIT_PVN;
 378     assert (!(proto && has_constant));
 379
 380     if (has_constant) {
 381         /* The constant has to be a scalar, array or subroutine.  */
 382         switch (SvTYPE(has_constant)) {
 383         case SVt_PVHV:
 384         case SVt_PVFM:
 385         case SVt_PVIO:
 386             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
 387                        sv_reftype(has_constant, 0));
 388
 389         default: NOOP;
 390         }
 391         SvRV_set(gv, NULL);
 392         SvROK_off(gv);
 393     }
 394
 395
 396     if (old_type < SVt_PVGV) {
 397         if (old_type >= SVt_PV)
 398             SvCUR_set(gv, 0);
 399         sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
 400     }
 401     if (SvLEN(gv)) {
 402         if (proto) {
 403             SvPV_set(gv, NULL);
 404             SvLEN_set(gv, 0);
 405             SvPOK_off(gv);
 406         } else
 407             Safefree(SvPVX_mutable(gv));
 408     }
 409     SvIOK_off(gv);
 410     isGV_with_GP_on(gv);
 411
 412     GvGP_set(gv, Perl_newGP(aTHX_ gv));
 413     GvSTASH(gv) = stash;
 414     if (stash)
 415         Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
 416     gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
 417     if (flags & GV_ADDMULTI || doproto) /* doproto means it */
 418         GvMULTI_on(gv);                 /* _was_ mentioned */
 419     if (has_constant && SvTYPE(has_constant) == SVt_PVCV) {
 420         /* Not actually a constant.  Just a regular sub.  */
 421         CV * const cv = (CV *)has_constant;
 422         GvCV_set(gv,cv);
 423         if (CvSTASH(cv) == stash && (
 424                CvNAME_HEK(cv) == GvNAME_HEK(gv)
 425             || (  HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
 426                && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
 427                && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
 428                && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
 429                )
 430            ))
 431             CvGV_set(cv,gv);
 432     }
 433     else if (doproto) {
 434         CV *cv;
 435         if (has_constant) {
 436             /* newCONSTSUB takes ownership of the reference from us.  */
 437             cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
 438             /* In case op.c:S_process_special_blocks stole it: */
 439             if (!GvCV(gv))
 440                 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
 441             assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
 442             /* If this reference was a copy of another, then the subroutine
 443                must have been "imported", by a Perl space assignment to a GV
 444                from a reference to CV.  */
 445             if (exported_constant)
 446                 GvIMPORTED_CV_on(gv);
 447             CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
 448         } else {
 449             cv = newSTUB(gv,1);
 450         }
 451         if (proto) {
 452             sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
 453                             SV_HAS_TRAILING_NUL);
 454             if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
 455         }
 456     }
 457 }
 458
 459 STATIC void
 460 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
 461 {
 462     PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
 463
 464     switch (sv_type) {
 465     case SVt_PVIO:
 466         (void)GvIOn(gv);
 467         break;
 468     case SVt_PVAV:
 469         (void)GvAVn(gv);
 470         break;
 471     case SVt_PVHV:
 472         (void)GvHVn(gv);
 473         break;
 474 #ifdef PERL_DONT_CREATE_GVSV
 475     case SVt_NULL:
 476     case SVt_PVCV:
 477     case SVt_PVFM:
 478     case SVt_PVGV:
 479         break;
 480     default:
 481         if(GvSVn(gv)) {
 482             /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
 483                If we just cast GvSVn(gv) to void, it ignores evaluating it for
 484                its side effect */
 485         }
 486 #endif
 487     }
 488 }
 489
 490 static void core_xsub(pTHX_ CV* cv);
 491
 492 static GV *
 493 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
 494                           const char * const name, const STRLEN len)
 495 {
 496     const int code = keyword(name, len, 1);
 497     static const char file[] = __FILE__;
 498     CV *cv, *oldcompcv = NULL;
 499     int opnum = 0;
 500     bool ampable = TRUE; /* &{}-able */
 501     COP *oldcurcop = NULL;
 502     yy_parser *oldparser = NULL;
 503     I32 oldsavestack_ix = 0;
 504
 505     assert(gv || stash);
 506     assert(name);
 507
 508     if (!code) return NULL; /* Not a keyword */
 509     switch (code < 0 ? -code : code) {
 510      /* no support for \&CORE::infix;
 511         no support for funcs that do not parse like funcs */
 512     case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
 513     case KEY_BEGIN   : case KEY_CHECK  : case KEY_cmp:
 514     case KEY_default : case KEY_DESTROY:
 515     case KEY_do      : case KEY_dump   : case KEY_else  : case KEY_elsif  :
 516     case KEY_END     : case KEY_eq     : case KEY_eval  :
 517     case KEY_for     : case KEY_foreach: case KEY_format: case KEY_ge     :
 518     case KEY_given   : case KEY_goto   : case KEY_grep  :
 519     case KEY_gt   : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
 520     case KEY_local: case KEY_lt: case KEY_m   : case KEY_map : case KEY_my:
 521     case KEY_ne   : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
 522     case KEY_package: case KEY_print: case KEY_printf:
 523     case KEY_q    : case KEY_qq   : case KEY_qr     : case KEY_qw    :
 524     case KEY_qx   : case KEY_redo : case KEY_require: case KEY_return:
 525     case KEY_s    : case KEY_say  : case KEY_sort   :
 526     case KEY_state: case KEY_sub  :
 527     case KEY_tr   : case KEY_UNITCHECK: case KEY_unless:
 528     case KEY_until: case KEY_use  : case KEY_when     : case KEY_while :
 529     case KEY_x    : case KEY_xor  : case KEY_y        :
 530         return NULL;
 531     case KEY_chdir:
 532     case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
 533     case KEY_each : case KEY_eof : case KEY_exec   : case KEY_exists:
 534     case KEY_keys:
 535     case KEY_lstat:
 536     case KEY_pop:
 537     case KEY_push:
 538     case KEY_shift:
 539     case KEY_splice: case KEY_split:
 540     case KEY_stat:
 541     case KEY_system:
 542     case KEY_truncate: case KEY_unlink:
 543     case KEY_unshift:
 544     case KEY_values:
 545         ampable = FALSE;
 546     }
 547     if (!gv) {
 548         gv = (GV *)newSV(0);
 549         gv_init(gv, stash, name, len, TRUE);
 550     }
 551     GvMULTI_on(gv);
 552     if (ampable) {
 553         ENTER;
 554         oldcurcop = PL_curcop;
 555         oldparser = PL_parser;
 556         lex_start(NULL, NULL, 0);
 557         oldcompcv = PL_compcv;
 558         PL_compcv = NULL; /* Prevent start_subparse from setting
 559                              CvOUTSIDE. */
 560         oldsavestack_ix = start_subparse(FALSE,0);
 561         cv = PL_compcv;
 562     }
 563     else {
 564         /* Avoid calling newXS, as it calls us, and things start to
 565            get hairy. */
 566         cv = MUTABLE_CV(newSV_type(SVt_PVCV));
 567         GvCV_set(gv,cv);
 568         GvCVGEN(gv) = 0;
 569         CvISXSUB_on(cv);
 570         CvXSUB(cv) = core_xsub;
 571     }
 572     CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
 573                          from PL_curcop. */
 574     (void)gv_fetchfile(file);
 575     CvFILE(cv) = (char *)file;
 576     /* XXX This is inefficient, as doing things this order causes
 577            a prototype check in newATTRSUB.  But we have to do
 578            it this order as we need an op number before calling
 579            new ATTRSUB. */
 580     (void)core_prototype((SV *)cv, name, code, &opnum);
 581     if (stash)
 582         (void)hv_store(stash,name,len,(SV *)gv,0);
 583     if (ampable) {
 584 #ifdef DEBUGGING
 585         CV *orig_cv = cv;
 586 #endif
 587         CvLVALUE_on(cv);
 588         /* newATTRSUB will free the CV and return NULL if we're still
 589            compiling after a syntax error */
 590         if ((cv = newATTRSUB_x(
 591                    oldsavestack_ix, (OP *)gv,
 592                    NULL,NULL,
 593                    coresub_op(
 594                      opnum
 595                        ? newSVuv((UV)opnum)
 596                        : newSVpvn(name,len),
 597                      code, opnum
 598                    ),
 599                    TRUE
 600                )) != NULL) {
 601             assert(GvCV(gv) == orig_cv);
 602             if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
 603                 && opnum != OP_UNDEF)
 604                 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
 605         }
 606         LEAVE;
 607         PL_parser = oldparser;
 608         PL_curcop = oldcurcop;
 609         PL_compcv = oldcompcv;
 610     }
 611     if (cv) {
 612         SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
 613         cv_set_call_checker(
 614           cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
 615         );
 616         SvREFCNT_dec(opnumsv);
 617     }
 618
 619     return gv;
 620 }
 621
 622 /*
 623 =for apidoc gv_fetchmeth
 624
 625 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
 626
 627 =for apidoc gv_fetchmeth_sv
 628
 629 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
 630 of an SV instead of a string/length pair.
 631
 632 =cut
 633 */
 634
 635 GV *
 636 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
 637 {
 638    char *namepv;
 639    STRLEN namelen;
 640    PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
 641    namepv = SvPV(namesv, namelen);
 642    if (SvUTF8(namesv))
 643        flags |= SVf_UTF8;
 644    return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
 645 }
 646
 647 /*
 648 =for apidoc gv_fetchmeth_pv
 649
 650 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
 651 instead of a string/length pair.
 652
 653 =cut
 654 */
 655
 656 GV *
 657 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
 658 {
 659     PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
 660     return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags);
 661 }
 662
 663 /*
 664 =for apidoc gv_fetchmeth_pvn
 665
 666 Returns the glob with the given C<name> and a defined subroutine or
 667 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
 668 accessible via @ISA and UNIVERSAL::.
 669
 670 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 671 side-effect creates a glob with the given C<name> in the given C<stash>
 672 which in the case of success contains an alias for the subroutine, and sets
 673 up caching info for this glob.
 674
 675 The only significant values for C<flags> are GV_SUPER and SVf_UTF8.
 676
 677 GV_SUPER indicates that we want to look up the method in the superclasses
 678 of the C<stash>.
 679
 680 The
 681 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 682 visible to Perl code.  So when calling C<call_sv>, you should not use
 683 the GV directly; instead, you should use the method's CV, which can be
 684 obtained from the GV with the C<GvCV> macro.
 685
 686 =cut
 687 */
 688
 689 /* NOTE: No support for tied ISA */
 690
 691 GV *
 692 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
 693 {
 694     GV** gvp;
 695     AV* linear_av;
 696     SV** linear_svp;
 697     SV* linear_sv;
 698     HV* cstash, *cachestash;
 699     GV* candidate = NULL;
 700     CV* cand_cv = NULL;
 701     GV* topgv = NULL;
 702     const char *hvname;
 703     I32 create = (level >= 0) ? 1 : 0;
 704     I32 items;
 705     U32 topgen_cmp;
 706     U32 is_utf8 = flags & SVf_UTF8;
 707
 708     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
 709
 710     /* UNIVERSAL methods should be callable without a stash */
 711     if (!stash) {
 712         create = 0;  /* probably appropriate */
 713         if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
 714             return 0;
 715     }
 716
 717     assert(stash);
 718
 719     hvname = HvNAME_get(stash);
 720     if (!hvname)
 721       Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 722
 723     assert(hvname);
 724     assert(name);
 725
 726     DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
 727                       flags & GV_SUPER ? "SUPER " : "",name,hvname) );
 728
 729     topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
 730
 731     if (flags & GV_SUPER) {
 732         if (!HvAUX(stash)->xhv_mro_meta->super)
 733             HvAUX(stash)->xhv_mro_meta->super = newHV();
 734         cachestash = HvAUX(stash)->xhv_mro_meta->super;
 735     }
 736     else cachestash = stash;
 737
 738     /* check locally for a real method or a cache entry */
 739     gvp = (GV**)hv_fetch(cachestash, name, is_utf8 ? -(I32)len : (I32)len,
 740                          create);
 741     if(gvp) {
 742         topgv = *gvp;
 743       have_gv:
 744         assert(topgv);
 745         if (SvTYPE(topgv) != SVt_PVGV)
 746             gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
 747         if ((cand_cv = GvCV(topgv))) {
 748             /* If genuine method or valid cache entry, use it */
 749             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
 750                 return topgv;
 751             }
 752             else {
 753                 /* stale cache entry, junk it and move on */
 754                 SvREFCNT_dec_NN(cand_cv);
 755                 GvCV_set(topgv, NULL);
 756                 cand_cv = NULL;
 757                 GvCVGEN(topgv) = 0;
 758             }
 759         }
 760         else if (GvCVGEN(topgv) == topgen_cmp) {
 761             /* cache indicates no such method definitively */
 762             return 0;
 763         }
 764         else if (stash == cachestash
 765               && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
 766               && strnEQ(hvname, "CORE", 4)
 767               && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
 768             goto have_gv;
 769     }
 770
 771     linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
 772     linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
 773     items = AvFILLp(linear_av); /* no +1, to skip over self */
 774     while (items--) {
 775         linear_sv = *linear_svp++;
 776         assert(linear_sv);
 777         cstash = gv_stashsv(linear_sv, 0);
 778
 779         if (!cstash) {
 780             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
 781                            "Can't locate package %"SVf" for @%"HEKf"::ISA",
 782                            SVfARG(linear_sv),
 783                            HEKfARG(HvNAME_HEK(stash)));
 784             continue;
 785         }
 786
 787         assert(cstash);
 788
 789         gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
 790         if (!gvp) {
 791             if (len > 1 && HvNAMELEN_get(cstash) == 4) {
 792                 const char *hvname = HvNAME(cstash); assert(hvname);
 793                 if (strnEQ(hvname, "CORE", 4)
 794                  && (candidate =
 795                       S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
 796                     ))
 797                     goto have_candidate;
 798             }
 799             continue;
 800         }
 801         else candidate = *gvp;
 802        have_candidate:
 803         assert(candidate);
 804         if (SvTYPE(candidate) != SVt_PVGV)
 805             gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
 806         if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 807             /*
 808              * Found real method, cache method in topgv if:
 809              *  1. topgv has no synonyms (else inheritance crosses wires)
 810              *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 811              */
 812             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 813                   CV *old_cv = GvCV(topgv);
 814                   SvREFCNT_dec(old_cv);
 815                   SvREFCNT_inc_simple_void_NN(cand_cv);
 816                   GvCV_set(topgv, cand_cv);
 817                   GvCVGEN(topgv) = topgen_cmp;
 818             }
 819             return candidate;
 820         }
 821     }
 822
 823     /* Check UNIVERSAL without caching */
 824     if(level == 0 || level == -1) {
 825         candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags &~GV_SUPER);
 826         if(candidate) {
 827             cand_cv = GvCV(candidate);
 828             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 829                   CV *old_cv = GvCV(topgv);
 830                   SvREFCNT_dec(old_cv);
 831                   SvREFCNT_inc_simple_void_NN(cand_cv);
 832                   GvCV_set(topgv, cand_cv);
 833                   GvCVGEN(topgv) = topgen_cmp;
 834             }
 835             return candidate;
 836         }
 837     }
 838
 839     if (topgv && GvREFCNT(topgv) == 1) {
 840         /* cache the fact that the method is not defined */
 841         GvCVGEN(topgv) = topgen_cmp;
 842     }
 843
 844     return 0;
 845 }
 846
 847 /*
 848 =for apidoc gv_fetchmeth_autoload
 849
 850 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
 851 parameter.
 852
 853 =for apidoc gv_fetchmeth_sv_autoload
 854
 855 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
 856 of an SV instead of a string/length pair.
 857
 858 =cut
 859 */
 860
 861 GV *
 862 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
 863 {
 864    char *namepv;
 865    STRLEN namelen;
 866    PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
 867    namepv = SvPV(namesv, namelen);
 868    if (SvUTF8(namesv))
 869        flags |= SVf_UTF8;
 870    return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
 871 }
 872
 873 /*
 874 =for apidoc gv_fetchmeth_pv_autoload
 875
 876 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
 877 instead of a string/length pair.
 878
 879 =cut
 880 */
 881
 882 GV *
 883 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
 884 {
 885     PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
 886     return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
 887 }
 888
 889 /*
 890 =for apidoc gv_fetchmeth_pvn_autoload
 891
 892 Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
 893 Returns a glob for the subroutine.
 894
 895 For an autoloaded subroutine without a GV, will create a GV even
 896 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
 897 of the result may be zero.
 898
 899 Currently, the only significant value for C<flags> is SVf_UTF8.
 900
 901 =cut
 902 */
 903
 904 GV *
 905 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
 906 {
 907     GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
 908
 909     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
 910
 911     if (!gv) {
 912         CV *cv;
 913         GV **gvp;
 914
 915         if (!stash)
 916             return NULL;        /* UNIVERSAL::AUTOLOAD could cause trouble */
 917         if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
 918             return NULL;
 919         if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
 920             return NULL;
 921         cv = GvCV(gv);
 922         if (!(CvROOT(cv) || CvXSUB(cv)))
 923             return NULL;
 924         /* Have an autoload */
 925         if (level < 0)  /* Cannot do without a stub */
 926             gv_fetchmeth_pvn(stash, name, len, 0, flags);
 927         gvp = (GV**)hv_fetch(stash, name,
 928                         (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
 929         if (!gvp)
 930             return NULL;
 931         return *gvp;
 932     }
 933     return gv;
 934 }
 935
 936 /*
 937 =for apidoc gv_fetchmethod_autoload
 938
 939 Returns the glob which contains the subroutine to call to invoke the method
 940 on the C<stash>.  In fact in the presence of autoloading this may be the
 941 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
 942 already setup.
 943
 944 The third parameter of C<gv_fetchmethod_autoload> determines whether
 945 AUTOLOAD lookup is performed if the given method is not present: non-zero
 946 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
 947 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
 948 with a non-zero C<autoload> parameter.
 949
 950 These functions grant C<"SUPER"> token
 951 as a prefix of the method name.  Note
 952 that if you want to keep the returned glob for a long time, you need to
 953 check for it being "AUTOLOAD", since at the later time the call may load a
 954 different subroutine due to $AUTOLOAD changing its value.  Use the glob
 955 created as a side effect to do this.
 956
 957 These functions have the same side-effects as C<gv_fetchmeth> with
 958 C<level==0>.  The warning against passing the GV returned by
 959 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
 960
 961 =cut
 962 */
 963
 964 GV *
 965 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 966 {
 967     PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
 968
 969     return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
 970 }
 971
 972 GV *
 973 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
 974 {
 975     char *namepv;
 976     STRLEN namelen;
 977     PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
 978     namepv = SvPV(namesv, namelen);
 979     if (SvUTF8(namesv))
 980        flags |= SVf_UTF8;
 981     return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
 982 }
 983
 984 GV *
 985 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
 986 {
 987     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
 988     return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
 989 }
 990
 991 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
 992    even a U32 hash */
 993 GV *
 994 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
 995 {
 996     const char *nend;
 997     const char *nsplit = NULL;
 998     GV* gv;
 999     HV* ostash = stash;
1000     const char * const origname = name;
1001     SV *const error_report = MUTABLE_SV(stash);
1002     const U32 autoload = flags & GV_AUTOLOAD;
1003     const U32 do_croak = flags & GV_CROAK;
1004     const U32 is_utf8  = flags & SVf_UTF8;
1005
1006     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
1007
1008     if (SvTYPE(stash) < SVt_PVHV)
1009         stash = NULL;
1010     else {
1011         /* The only way stash can become NULL later on is if nsplit is set,
1012            which in turn means that there is no need for a SVt_PVHV case
1013            the error reporting code.  */
1014     }
1015
1016     for (nend = name; *nend || nend != (origname + len); nend++) {
1017         if (*nend == '\'') {
1018             nsplit = nend;
1019             name = nend + 1;
1020         }
1021         else if (*nend == ':' && *(nend + 1) == ':') {
1022             nsplit = nend++;
1023             name = nend + 1;
1024         }
1025     }
1026     if (nsplit) {
1027         if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
1028             /* ->SUPER::method should really be looked up in original stash */
1029             stash = CopSTASH(PL_curcop);
1030             flags |= GV_SUPER;
1031             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1032                          origname, HvENAME_get(stash), name) );
1033         }
1034         else if ((nsplit - origname) >= 7 &&
1035                  strnEQ(nsplit - 7, "::SUPER", 7)) {
1036             /* don't autovifify if ->NoSuchStash::SUPER::method */
1037             stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
1038             if (stash) flags |= GV_SUPER;
1039         }
1040         else {
1041             /* don't autovifify if ->NoSuchStash::method */
1042             stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
1043         }
1044         ostash = stash;
1045     }
1046
1047     gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1048     if (!gv) {
1049         if (strEQ(name,"import") || strEQ(name,"unimport"))
1050             gv = MUTABLE_GV(&PL_sv_yes);
1051         else if (autoload)
1052             gv = gv_autoload_pvn(
1053                 ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
1054             );
1055         if (!gv && do_croak) {
1056             /* Right now this is exclusively for the benefit of S_method_common
1057                in pp_hot.c  */
1058             if (stash) {
1059                 /* If we can't find an IO::File method, it might be a call on
1060                  * a filehandle. If IO:File has not been loaded, try to
1061                  * require it first instead of croaking */
1062                 const char *stash_name = HvNAME_get(stash);
1063                 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1064                     && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1065                                        STR_WITH_LEN("IO/File.pm"), 0,
1066                                        HV_FETCH_ISEXISTS, NULL, 0)
1067                 ) {
1068                     require_pv("IO/File.pm");
1069                     gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1070                     if (gv)
1071                         return gv;
1072                 }
1073                 Perl_croak(aTHX_
1074                            "Can't locate object method \"%"UTF8f
1075                            "\" via package \"%"HEKf"\"",
1076                                     UTF8fARG(is_utf8, nend - name, name),
1077                                     HEKfARG(HvNAME_HEK(stash)));
1078             }
1079             else {
1080                 SV* packnamesv;
1081
1082                 if (nsplit) {
1083                     packnamesv = newSVpvn_flags(origname, nsplit - origname,
1084                                                     SVs_TEMP | is_utf8);
1085                 } else {
1086                     packnamesv = error_report;
1087                 }
1088
1089                 Perl_croak(aTHX_
1090                            "Can't locate object method \"%"UTF8f
1091                            "\" via package \"%"SVf"\""
1092                            " (perhaps you forgot to load \"%"SVf"\"?)",
1093                            UTF8fARG(is_utf8, nend - name, name),
1094                            SVfARG(packnamesv), SVfARG(packnamesv));
1095             }
1096         }
1097     }
1098     else if (autoload) {
1099         CV* const cv = GvCV(gv);
1100         if (!CvROOT(cv) && !CvXSUB(cv)) {
1101             GV* stubgv;
1102             GV* autogv;
1103
1104             if (CvANON(cv) || CvLEXICAL(cv))
1105                 stubgv = gv;
1106             else {
1107                 stubgv = CvGV(cv);
1108                 if (GvCV(stubgv) != cv)         /* orphaned import */
1109                     stubgv = gv;
1110             }
1111             autogv = gv_autoload_pvn(GvSTASH(stubgv),
1112                                   GvNAME(stubgv), GvNAMELEN(stubgv),
1113                                   GV_AUTOLOAD_ISMETHOD
1114                                    | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1115             if (autogv)
1116                 gv = autogv;
1117         }
1118     }
1119
1120     return gv;
1121 }
1122
1123 GV*
1124 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1125 {
1126    char *namepv;
1127    STRLEN namelen;
1128    PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1129    namepv = SvPV(namesv, namelen);
1130    if (SvUTF8(namesv))
1131        flags |= SVf_UTF8;
1132    return gv_autoload_pvn(stash, namepv, namelen, flags);
1133 }
1134
1135 GV*
1136 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1137 {
1138    PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1139    return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1140 }
1141
1142 GV*
1143 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1144 {
1145     GV* gv;
1146     CV* cv;
1147     HV* varstash;
1148     GV* vargv;
1149     SV* varsv;
1150     SV *packname = NULL;
1151     U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1152
1153     PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1154
1155     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1156         return NULL;
1157     if (stash) {
1158         if (SvTYPE(stash) < SVt_PVHV) {
1159             STRLEN packname_len = 0;
1160             const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1161             packname = newSVpvn_flags(packname_ptr, packname_len,
1162                                       SVs_TEMP | SvUTF8(stash));
1163             stash = NULL;
1164         }
1165         else
1166             packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1167         if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1168     }
1169     if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1170                                 is_utf8 | (flags & GV_SUPER))))
1171         return NULL;
1172     cv = GvCV(gv);
1173
1174     if (!(CvROOT(cv) || CvXSUB(cv)))
1175         return NULL;
1176
1177     /*
1178      * Inheriting AUTOLOAD for non-methods works ... for now.
1179      */
1180     if (
1181         !(flags & GV_AUTOLOAD_ISMETHOD)
1182      && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1183     )
1184         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1185                          "Use of inherited AUTOLOAD for non-method %"SVf
1186                          "::%"UTF8f"() is deprecated",
1187                          SVfARG(packname),
1188                          UTF8fARG(is_utf8, len, name));
1189
1190     if (CvISXSUB(cv)) {
1191         /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1192          * and split that value on the last '::', pass along the same data
1193          * via the SvPVX field in the CV, and the stash in CvSTASH.
1194          *
1195          * Due to an unfortunate accident of history, the SvPVX field
1196          * serves two purposes.  It is also used for the subroutine's pro-
1197          * type.  Since SvPVX has been documented as returning the sub name
1198          * for a long time, but not as returning the prototype, we have
1199          * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1200          * elsewhere.
1201          *
1202          * We put the prototype in the same allocated buffer, but after
1203          * the sub name.  The SvPOK flag indicates the presence of a proto-
1204          * type.  The CvAUTOLOAD flag indicates the presence of a sub name.
1205          * If both flags are on, then SvLEN is used to indicate the end of
1206          * the prototype (artificially lower than what is actually allo-
1207          * cated), at the risk of having to reallocate a few bytes unneces-
1208          * sarily--but that should happen very rarely, if ever.
1209          *
1210          * We use SvUTF8 for both prototypes and sub names, so if one is
1211          * UTF8, the other must be upgraded.
1212          */
1213         CvSTASH_set(cv, stash);
1214         if (SvPOK(cv)) { /* Ouch! */
1215             SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1216             STRLEN ulen;
1217             const char *proto = CvPROTO(cv);
1218             assert(proto);
1219             if (SvUTF8(cv))
1220                 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1221             ulen = SvCUR(tmpsv);
1222             SvCUR(tmpsv)++; /* include null in string */
1223             sv_catpvn_flags(
1224                 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1225             );
1226             SvTEMP_on(tmpsv); /* Allow theft */
1227             sv_setsv_nomg((SV *)cv, tmpsv);
1228             SvTEMP_off(tmpsv);
1229             SvREFCNT_dec_NN(tmpsv);
1230             SvLEN(cv) = SvCUR(cv) + 1;
1231             SvCUR(cv) = ulen;
1232         }
1233         else {
1234           sv_setpvn((SV *)cv, name, len);
1235           SvPOK_off(cv);
1236           if (is_utf8)
1237             SvUTF8_on(cv);
1238           else SvUTF8_off(cv);
1239         }
1240         CvAUTOLOAD_on(cv);
1241     }
1242
1243     /*
1244      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1245      * The subroutine's original name may not be "AUTOLOAD", so we don't
1246      * use that, but for lack of anything better we will use the sub's
1247      * original package to look up $AUTOLOAD.
1248      */
1249     varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1250     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1251     ENTER;
1252
1253     if (!isGV(vargv)) {
1254         gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1255 #ifdef PERL_DONT_CREATE_GVSV
1256         GvSV(vargv) = newSV(0);
1257 #endif
1258     }
1259     LEAVE;
1260     varsv = GvSVn(vargv);
1261     SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1262     /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1263     sv_setsv(varsv, packname);
1264     sv_catpvs(varsv, "::");
1265     /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1266        tainting if $FOO::AUTOLOAD was previously tainted, but is not now.  */
1267     sv_catpvn_flags(
1268         varsv, name, len,
1269         SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1270     );
1271     if (is_utf8)
1272         SvUTF8_on(varsv);
1273     return gv;
1274 }
1275
1276
1277 /* require_tie_mod() internal routine for requiring a module
1278  * that implements the logic of automatic ties like %! and %-
1279  *
1280  * The "gv" parameter should be the glob.
1281  * "varpv" holds the name of the var, used for error messages.
1282  * "namesv" holds the module name. Its refcount will be decremented.
1283  * "methpv" holds the method name to test for to check that things
1284  *   are working reasonably close to as expected.
1285  * "flags": if flag & 1 then save the scalar before loading.
1286  * For the protection of $! to work (it is set by this routine)
1287  * the sv slot must already be magicalized.
1288  */
1289 STATIC HV*
1290 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1291 {
1292     HV* stash = gv_stashsv(namesv, 0);
1293
1294     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1295
1296     if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
1297         SV *module = newSVsv(namesv);
1298         char varname = *varpv; /* varpv might be clobbered by load_module,
1299                                   so save it. For the moment it's always
1300                                   a single char. */
1301         const char type = varname == '[' ? '$' : '%';
1302 #ifdef DEBUGGING
1303         dSP;
1304 #endif
1305         ENTER;
1306         SAVEFREESV(namesv);
1307         if ( flags & 1 )
1308             save_scalar(gv);
1309         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1310         assert(sp == PL_stack_sp);
1311         stash = gv_stashsv(namesv, 0);
1312         if (!stash)
1313             Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
1314                     type, varname, SVfARG(namesv));
1315         else if (!gv_fetchmethod(stash, methpv))
1316             Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
1317                     type, varname, SVfARG(namesv), methpv);
1318         LEAVE;
1319     }
1320     else SvREFCNT_dec_NN(namesv);
1321     return stash;
1322 }
1323
1324 /*
1325 =for apidoc gv_stashpv
1326
1327 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
1328 determine the length of C<name>, then calls C<gv_stashpvn()>.
1329
1330 =cut
1331 */
1332
1333 HV*
1334 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1335 {
1336     PERL_ARGS_ASSERT_GV_STASHPV;
1337     return gv_stashpvn(name, strlen(name), create);
1338 }
1339
1340 /*
1341 =for apidoc gv_stashpvn
1342
1343 Returns a pointer to the stash for a specified package.  The C<namelen>
1344 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
1345 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1346 created if it does not already exist.  If the package does not exist and
1347 C<flags> is 0 (or any other setting that does not create packages) then NULL
1348 is returned.
1349
1350 Flags may be one of:
1351
1352     GV_ADD
1353     SVf_UTF8
1354     GV_NOADD_NOINIT
1355     GV_NOINIT
1356     GV_NOEXPAND
1357     GV_ADDMG
1358
1359 The most important of which are probably GV_ADD and SVf_UTF8.
1360
1361 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1362 recommended for performance reasons.
1363
1364 =cut
1365 */
1366
1367 /*
1368 gv_stashpvn_internal
1369
1370 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1371 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1372
1373 */
1374
1375 PERL_STATIC_INLINE HV*
1376 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1377 {
1378     char smallbuf[128];
1379     char *tmpbuf;
1380     HV *stash;
1381     GV *tmpgv;
1382     U32 tmplen = namelen + 2;
1383
1384     PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1385
1386     if (tmplen <= sizeof smallbuf)
1387         tmpbuf = smallbuf;
1388     else
1389         Newx(tmpbuf, tmplen, char);
1390     Copy(name, tmpbuf, namelen, char);
1391     tmpbuf[namelen]   = ':';
1392     tmpbuf[namelen+1] = ':';
1393     tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1394     if (tmpbuf != smallbuf)
1395         Safefree(tmpbuf);
1396     if (!tmpgv)
1397         return NULL;
1398     stash = GvHV(tmpgv);
1399     if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1400     assert(stash);
1401     if (!HvNAME_get(stash)) {
1402         hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1403
1404         /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1405         /* If the containing stash has multiple effective
1406            names, see that this one gets them, too. */
1407         if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1408             mro_package_moved(stash, NULL, tmpgv, 1);
1409     }
1410     return stash;
1411 }
1412
1413 /*
1414 gv_stashsvpvn_cached
1415
1416 Returns a pointer to the stash for a specified package, possibly
1417 cached.  Implements both C<gv_stashpvn> and C<gc_stashsv>.
1418
1419 Requires one of either namesv or namepv to be non-null.
1420
1421 See C<gv_stashpvn> for details on "flags".
1422
1423 Note the sv interface is strongly preferred for performance reasons.
1424
1425 */
1426
1427 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1428     assert(namesv || name)
1429
1430 PERL_STATIC_INLINE HV*
1431 S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1432 {
1433     HV* stash;
1434     HE* he;
1435
1436     PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1437
1438     he = (HE *)hv_common(
1439         PL_stashcache, namesv, name, namelen,
1440         (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1441     );
1442
1443     if (he) return INT2PTR(HV*,SvIVX(HeVAL(he)));
1444     else if (flags & GV_CACHE_ONLY) return NULL;
1445
1446     if (namesv) {
1447         if (SvOK(namesv)) { /* prevent double uninit warning */
1448             STRLEN len;
1449             name = SvPV_const(namesv, len);
1450             namelen = len;
1451             flags |= SvUTF8(namesv);
1452         } else {
1453             name = ""; namelen = 0;
1454         }
1455     }
1456     stash = gv_stashpvn_internal(name, namelen, flags);
1457
1458     if (stash && namelen) {
1459         SV* const ref = newSViv(PTR2IV(stash));
1460         (void)hv_store(PL_stashcache, name,
1461             (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1462     }
1463
1464     return stash;
1465 }
1466
1467 HV*
1468 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1469 {
1470     PERL_ARGS_ASSERT_GV_STASHPVN;
1471     return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1472 }
1473
1474 /*
1475 =for apidoc gv_stashsv
1476
1477 Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
1478
1479 Note this interface is strongly preferred over C<gv_stashpvn> for performance reasons.
1480
1481 =cut
1482 */
1483
1484 HV*
1485 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1486 {
1487     PERL_ARGS_ASSERT_GV_STASHSV;
1488     return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1489 }
1490
1491
1492 GV *
1493 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1494     PERL_ARGS_ASSERT_GV_FETCHPV;
1495     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1496 }
1497
1498 GV *
1499 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1500     STRLEN len;
1501     const char * const nambeg =
1502        SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1503     PERL_ARGS_ASSERT_GV_FETCHSV;
1504     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1505 }
1506
1507 PERL_STATIC_INLINE void
1508 S_gv_magicalize_isa(pTHX_ GV *gv)
1509 {
1510     AV* av;
1511
1512     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1513
1514     av = GvAVn(gv);
1515     GvMULTI_on(gv);
1516     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1517              NULL, 0);
1518 }
1519
1520 /* This function grabs name and tries to split a stash and glob
1521  * from its contents. TODO better description, comments
1522  *
1523  * If the function returns TRUE and 'name == name_end', then
1524  * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1525  */
1526 PERL_STATIC_INLINE bool
1527 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1528                STRLEN *len, const char *nambeg, STRLEN full_len,
1529                const U32 is_utf8, const I32 add)
1530 {
1531     const char *name_cursor;
1532     const char *const name_end = nambeg + full_len;
1533     const char *const name_em1 = name_end - 1;
1534
1535     PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1536
1537     if (full_len > 2 && **name == '*' && isIDFIRST_lazy_if(*name + 1, is_utf8)) {
1538         /* accidental stringify on a GV? */
1539         (*name)++;
1540     }
1541
1542     for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1543         if (name_cursor < name_em1 &&
1544             ((*name_cursor == ':' && name_cursor[1] == ':')
1545            || *name_cursor == '\''))
1546         {
1547             if (!*stash)
1548                 *stash = PL_defstash;
1549             if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1550                 return FALSE;
1551
1552             *len = name_cursor - *name;
1553             if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1554                 const char *key;
1555                 GV**gvp;
1556                 if (*name_cursor == ':') {
1557                     key = *name;
1558                     *len += 2;
1559                 }
1560                 else {
1561                     char *tmpbuf;
1562                     Newx(tmpbuf, *len+2, char);
1563                     Copy(*name, tmpbuf, *len, char);
1564                     tmpbuf[(*len)++] = ':';
1565                     tmpbuf[(*len)++] = ':';
1566                     key = tmpbuf;
1567                 }
1568                 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1569                 *gv = gvp ? *gvp : NULL;
1570                 if (*gv && *gv != (const GV *)&PL_sv_undef) {
1571                     if (SvTYPE(*gv) != SVt_PVGV)
1572                         gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1573                     else
1574                         GvMULTI_on(*gv);
1575                 }
1576                 if (key != *name)
1577                     Safefree(key);
1578                 if (!*gv || *gv == (const GV *)&PL_sv_undef)
1579                     return FALSE;
1580
1581                 if (!(*stash = GvHV(*gv))) {
1582                     *stash = GvHV(*gv) = newHV();
1583                     if (!HvNAME_get(*stash)) {
1584                         if (GvSTASH(*gv) == PL_defstash && *len == 6
1585                             && strnEQ(*name, "CORE", 4))
1586                             hv_name_set(*stash, "CORE", 4, 0);
1587                         else
1588                             hv_name_set(
1589                                 *stash, nambeg, name_cursor-nambeg, is_utf8
1590                             );
1591                     /* If the containing stash has multiple effective
1592                     names, see that this one gets them, too. */
1593                     if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1594                         mro_package_moved(*stash, NULL, *gv, 1);
1595                     }
1596                 }
1597                 else if (!HvNAME_get(*stash))
1598                     hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1599             }
1600
1601             if (*name_cursor == ':')
1602                 name_cursor++;
1603             *name = name_cursor+1;
1604             if (*name == name_end) {
1605                 if (!*gv)
1606                     *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1607                 return TRUE;
1608             }
1609         }
1610     }
1611     *len = name_cursor - *name;
1612     return TRUE;
1613 }
1614
1615 /* Checks if an unqualified name is in the main stash */
1616 PERL_STATIC_INLINE bool
1617 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1618 {
1619     PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1620
1621     /* If it's an alphanumeric variable */
1622     if ( len && isIDFIRST_lazy_if(name, is_utf8) ) {
1623         /* Some "normal" variables are always in main::,
1624          * like INC or STDOUT.
1625          */
1626         switch (len) {
1627             case 1:
1628             if (*name == '_')
1629                 return TRUE;
1630             break;
1631             case 3:
1632             if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1633                 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1634                 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1635                 return TRUE;
1636             break;
1637             case 4:
1638             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1639                 && name[3] == 'V')
1640                 return TRUE;
1641             break;
1642             case 5:
1643             if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1644                 && name[3] == 'I' && name[4] == 'N')
1645                 return TRUE;
1646             break;
1647             case 6:
1648             if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1649                 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1650                     ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1651                 return TRUE;
1652             break;
1653             case 7:
1654             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1655                 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1656                 && name[6] == 'T')
1657                 return TRUE;
1658             break;
1659         }
1660     }
1661     /* *{""}, or a special variable like $@ */
1662     else
1663         return TRUE;
1664
1665     return FALSE;
1666 }
1667
1668
1669 /* This function is called if parse_gv_stash_name() failed to
1670  * find a stash, or if GV_NOTQUAL or an empty name was passed
1671  * to gv_fetchpvn_flags.
1672  *
1673  * It returns FALSE if the default stash can't be found nor created,
1674  * which might happen during global destruction.
1675  */
1676 PERL_STATIC_INLINE bool
1677 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1678                const U32 is_utf8, const I32 add,
1679                const svtype sv_type)
1680 {
1681     PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1682
1683     /* No stash in name, so see how we can default */
1684
1685     if ( gv_is_in_main(name, len, is_utf8) ) {
1686         *stash = PL_defstash;
1687     }
1688     else {
1689         if (IN_PERL_COMPILETIME) {
1690             *stash = PL_curstash;
1691             if (add && (PL_hints & HINT_STRICT_VARS) &&
1692                 sv_type != SVt_PVCV &&
1693                 sv_type != SVt_PVGV &&
1694                 sv_type != SVt_PVFM &&
1695                 sv_type != SVt_PVIO &&
1696                 !(len == 1 && sv_type == SVt_PV &&
1697                 (*name == 'a' || *name == 'b')) )
1698             {
1699                 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1700                 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1701                     SvTYPE(*gvp) != SVt_PVGV)
1702                 {
1703                     *stash = NULL;
1704                 }
1705                 else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1706                          (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1707                          (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1708                 {
1709                     /* diag_listed_as: Variable "%s" is not imported%s */
1710                     Perl_ck_warner_d(
1711                         aTHX_ packWARN(WARN_MISC),
1712                         "Variable \"%c%"UTF8f"\" is not imported",
1713                         sv_type == SVt_PVAV ? '@' :
1714                         sv_type == SVt_PVHV ? '%' : '$',
1715                         UTF8fARG(is_utf8, len, name));
1716                     if (GvCVu(*gvp))
1717                         Perl_ck_warner_d(
1718                             aTHX_ packWARN(WARN_MISC),
1719                             "\t(Did you mean &%"UTF8f" instead?)\n",
1720                             UTF8fARG(is_utf8, len, name)
1721                         );
1722                     *stash = NULL;
1723                 }
1724             }
1725         }
1726         else {
1727             /* Use the current op's stash */
1728             *stash = CopSTASH(PL_curcop);
1729         }
1730     }
1731
1732     if (!*stash) {
1733         if (add && !PL_in_clean_all) {
1734             GV *gv;
1735             qerror(Perl_mess(aTHX_
1736                  "Global symbol \"%s%"UTF8f
1737                  "\" requires explicit package name (did you forget to "
1738                  "declare \"my %s%"UTF8f"\"?)",
1739                  (sv_type == SVt_PV ? "$"
1740                   : sv_type == SVt_PVAV ? "@"
1741                   : sv_type == SVt_PVHV ? "%"
1742                   : ""), UTF8fARG(is_utf8, len, name),
1743                  (sv_type == SVt_PV ? "$"
1744                   : sv_type == SVt_PVAV ? "@"
1745                   : sv_type == SVt_PVHV ? "%"
1746                   : ""), UTF8fARG(is_utf8, len, name)));
1747             /* To maintain the output of errors after the strict exception
1748              * above, and to keep compat with older releases, rather than
1749              * placing the variables in the pad, we place
1750              * them in the <none>:: stash.
1751              */
1752             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1753             if (!gv) {
1754                 /* symbol table under destruction */
1755                 return FALSE;
1756             }
1757             *stash = GvHV(gv);
1758         }
1759         else
1760             return FALSE;
1761     }
1762
1763     if (!SvREFCNT(*stash))   /* symbol table under destruction */
1764         return FALSE;
1765
1766     return TRUE;
1767 }
1768
1769 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1770  * a new GV.
1771  * Note that it does not insert the GV into the stash prior to
1772  * magicalization, which some variables require need in order
1773  * to work (like $[, %+, %-, %!), so callers must take care of
1774  * that beforehand.
1775  *
1776  * The return value has a specific meaning for gv_fetchpvn_flags:
1777  * If it returns true, and the gv is empty, it indicates that its
1778  * refcount should be decreased.
1779  */
1780 PERL_STATIC_INLINE bool
1781 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1782                bool addmg, const svtype sv_type)
1783 {
1784     SSize_t paren;
1785
1786     PERL_ARGS_ASSERT_GV_MAGICALIZE;
1787
1788     if (stash != PL_defstash) { /* not the main stash */
1789         /* We only have to check for a few names here: a, b, EXPORT, ISA
1790            and VERSION. All the others apply only to the main stash or to
1791            CORE (which is checked right after this). */
1792         if (len) {
1793             const char * const name2 = name + 1;
1794             switch (*name) {
1795             case 'E':
1796                 if (strnEQ(name2, "XPORT", 5))
1797                     GvMULTI_on(gv);
1798                 break;
1799             case 'I':
1800                 if (strEQ(name2, "SA"))
1801                     gv_magicalize_isa(gv);
1802                 break;
1803             case 'V':
1804                 if (strEQ(name2, "ERSION"))
1805                     GvMULTI_on(gv);
1806                 break;
1807             case 'a':
1808             case 'b':
1809                 if (len == 1 && sv_type == SVt_PV)
1810                     GvMULTI_on(gv);
1811                 /* FALLTHROUGH */
1812             default:
1813                 goto try_core;
1814             }
1815             return addmg;
1816         }
1817       try_core:
1818         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1819           /* Avoid null warning: */
1820           const char * const stashname = HvNAME(stash); assert(stashname);
1821           if (strnEQ(stashname, "CORE", 4))
1822             S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1823         }
1824     }
1825     else if (len > 1) {
1826 #ifndef EBCDIC
1827         if (*name > 'V' ) {
1828             NOOP;
1829             /* Nothing else to do.
1830                The compiler will probably turn the switch statement into a
1831                branch table. Make sure we avoid even that small overhead for
1832                the common case of lower case variable names.  (On EBCDIC
1833                platforms, we can't just do:
1834                  if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1835                because cases like '\027' in the switch statement below are
1836                C1 (non-ASCII) controls on those platforms, so the remapping
1837                would make them larger than 'V')
1838              */
1839         } else
1840 #endif
1841         {
1842             const char * const name2 = name + 1;
1843             switch (*name) {
1844             case 'A':
1845                 if (strEQ(name2, "RGV")) {
1846                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1847                 }
1848                 else if (strEQ(name2, "RGVOUT")) {
1849                     GvMULTI_on(gv);
1850                 }
1851                 break;
1852             case 'E':
1853                 if (strnEQ(name2, "XPORT", 5))
1854                     GvMULTI_on(gv);
1855                 break;
1856             case 'I':
1857                 if (strEQ(name2, "SA")) {
1858                     gv_magicalize_isa(gv);
1859                 }
1860                 break;
1861             case 'S':
1862                 if (strEQ(name2, "IG")) {
1863                     HV *hv;
1864                     I32 i;
1865                     if (!PL_psig_name) {
1866                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1867                         Newxz(PL_psig_pend, SIG_SIZE, int);
1868                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1869                     } else {
1870                         /* I think that the only way to get here is to re-use an
1871                            embedded perl interpreter, where the previous
1872                            use didn't clean up fully because
1873                            PL_perl_destruct_level was 0. I'm not sure that we
1874                            "support" that, in that I suspect in that scenario
1875                            there are sufficient other garbage values left in the
1876                            interpreter structure that something else will crash
1877                            before we get here. I suspect that this is one of
1878                            those "doctor, it hurts when I do this" bugs.  */
1879                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1880                         Zero(PL_psig_pend, SIG_SIZE, int);
1881                     }
1882                     GvMULTI_on(gv);
1883                     hv = GvHVn(gv);
1884                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1885                     for (i = 1; i < SIG_SIZE; i++) {
1886                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1887                         if (init)
1888                             sv_setsv(*init, &PL_sv_undef);
1889                     }
1890                 }
1891                 break;
1892             case 'V':
1893                 if (strEQ(name2, "ERSION"))
1894                     GvMULTI_on(gv);
1895                 break;
1896             case '\003':        /* $^CHILD_ERROR_NATIVE */
1897                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1898                     goto magicalize;
1899                 break;
1900             case '\005':        /* $^ENCODING */
1901                 if (strEQ(name2, "NCODING"))
1902                     goto magicalize;
1903                 break;
1904             case '\007':        /* $^GLOBAL_PHASE */
1905                 if (strEQ(name2, "LOBAL_PHASE"))
1906                     goto ro_magicalize;
1907                 break;
1908             case '\014':        /* $^LAST_FH */
1909                 if (strEQ(name2, "AST_FH"))
1910                     goto ro_magicalize;
1911                 break;
1912             case '\015':        /* $^MATCH */
1913                 if (strEQ(name2, "ATCH")) {
1914                     paren = RX_BUFF_IDX_CARET_FULLMATCH;
1915                     goto storeparen;
1916                 }
1917                 break;
1918             case '\017':        /* $^OPEN */
1919                 if (strEQ(name2, "PEN"))
1920                     goto magicalize;
1921                 break;
1922             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1923                 if (strEQ(name2, "REMATCH")) {
1924                     paren = RX_BUFF_IDX_CARET_PREMATCH;
1925                     goto storeparen;
1926                 }
1927                 if (strEQ(name2, "OSTMATCH")) {
1928                     paren = RX_BUFF_IDX_CARET_POSTMATCH;
1929                     goto storeparen;
1930                 }
1931                 break;
1932             case '\024':        /* ${^TAINT} */
1933                 if (strEQ(name2, "AINT"))
1934                     goto ro_magicalize;
1935                 break;
1936             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1937                 if (strEQ(name2, "NICODE"))
1938                     goto ro_magicalize;
1939                 if (strEQ(name2, "TF8LOCALE"))
1940                     goto ro_magicalize;
1941                 if (strEQ(name2, "TF8CACHE"))
1942                     goto magicalize;
1943                 break;
1944             case '\027':        /* $^WARNING_BITS */
1945                 if (strEQ(name2, "ARNING_BITS"))
1946                     goto magicalize;
1947                 break;
1948             case '1':
1949             case '2':
1950             case '3':
1951             case '4':
1952             case '5':
1953             case '6':
1954             case '7':
1955             case '8':
1956             case '9':
1957             {
1958                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1959                    this test  */
1960                 /* This snippet is taken from is_gv_magical */
1961                 const char *end = name + len;
1962                 while (--end > name) {
1963                     if (!isDIGIT(*end))
1964                         return addmg;
1965                 }
1966                 paren = grok_atou(name, NULL);
1967                 goto storeparen;
1968             }
1969             }
1970         }
1971     } else {
1972         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1973            be case '\0' in this switch statement (ie a default case)  */
1974         switch (*name) {
1975         case '&':               /* $& */
1976             paren = RX_BUFF_IDX_FULLMATCH;
1977             goto sawampersand;
1978         case '`':               /* $` */
1979             paren = RX_BUFF_IDX_PREMATCH;
1980             goto sawampersand;
1981         case '\'':              /* $' */
1982             paren = RX_BUFF_IDX_POSTMATCH;
1983         sawampersand:
1984 #ifdef PERL_SAWAMPERSAND
1985             if (!(
1986                 sv_type == SVt_PVAV ||
1987                 sv_type == SVt_PVHV ||
1988                 sv_type == SVt_PVCV ||
1989                 sv_type == SVt_PVFM ||
1990                 sv_type == SVt_PVIO
1991                 )) { PL_sawampersand |=
1992                         (*name == '`')
1993                             ? SAWAMPERSAND_LEFT
1994                             : (*name == '&')
1995                                 ? SAWAMPERSAND_MIDDLE
1996                                 : SAWAMPERSAND_RIGHT;
1997                 }
1998 #endif
1999             goto storeparen;
2000         case '1':               /* $1 */
2001         case '2':               /* $2 */
2002         case '3':               /* $3 */
2003         case '4':               /* $4 */
2004         case '5':               /* $5 */
2005         case '6':               /* $6 */
2006         case '7':               /* $7 */
2007         case '8':               /* $8 */
2008         case '9':               /* $9 */
2009             paren = *name - '0';
2010
2011         storeparen:
2012             /* Flag the capture variables with a NULL mg_ptr
2013                Use mg_len for the array index to lookup.  */
2014             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
2015             break;
2016
2017         case ':':               /* $: */
2018             sv_setpv(GvSVn(gv),PL_chopset);
2019             goto magicalize;
2020
2021         case '?':               /* $? */
2022 #ifdef COMPLEX_STATUS
2023             SvUPGRADE(GvSVn(gv), SVt_PVLV);
2024 #endif
2025             goto magicalize;
2026
2027         case '!':               /* $! */
2028             GvMULTI_on(gv);
2029             /* If %! has been used, automatically load Errno.pm. */
2030
2031             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2032
2033             /* magicalization must be done before require_tie_mod is called */
2034             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2035             {
2036                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
2037                 addmg = FALSE;
2038             }
2039
2040             break;
2041         case '-':               /* $- */
2042         case '+':               /* $+ */
2043         GvMULTI_on(gv); /* no used once warnings here */
2044         {
2045             AV* const av = GvAVn(gv);
2046             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
2047
2048             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
2049             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2050             if (avc)
2051                 SvREADONLY_on(GvSVn(gv));
2052             SvREADONLY_on(av);
2053
2054             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2055             {
2056                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
2057                 addmg = FALSE;
2058             }
2059
2060             break;
2061         }
2062         case '*':               /* $* */
2063         case '#':               /* $# */
2064             if (sv_type == SVt_PV)
2065                 /* diag_listed_as: $* is no longer supported */
2066                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
2067                                  "$%c is no longer supported", *name);
2068             break;
2069         case '\010':    /* $^H */
2070             {
2071                 HV *const hv = GvHVn(gv);
2072                 hv_magic(hv, NULL, PERL_MAGIC_hints);
2073             }
2074             goto magicalize;
2075         case '[':               /* $[ */
2076             if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
2077              && FEATURE_ARYBASE_IS_ENABLED) {
2078                 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
2079                 addmg = FALSE;
2080             }
2081             else goto magicalize;
2082             break;
2083         case '\023':    /* $^S */
2084         ro_magicalize:
2085             SvREADONLY_on(GvSVn(gv));
2086             /* FALLTHROUGH */
2087         case '0':               /* $0 */
2088         case '^':               /* $^ */
2089         case '~':               /* $~ */
2090         case '=':               /* $= */
2091         case '%':               /* $% */
2092         case '.':               /* $. */
2093         case '(':               /* $( */
2094         case ')':               /* $) */
2095         case '<':               /* $< */
2096         case '>':               /* $> */
2097         case '\\':              /* $\ */
2098         case '/':               /* $/ */
2099         case '|':               /* $| */
2100         case '$':               /* $$ */
2101         case '\001':    /* $^A */
2102         case '\003':    /* $^C */
2103         case '\004':    /* $^D */
2104         case '\005':    /* $^E */
2105         case '\006':    /* $^F */
2106         case '\011':    /* $^I, NOT \t in EBCDIC */
2107         case '\016':    /* $^N */
2108         case '\017':    /* $^O */
2109         case '\020':    /* $^P */
2110         case '\024':    /* $^T */
2111         case '\027':    /* $^W */
2112         magicalize:
2113             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2114             break;
2115
2116         case '\014':    /* $^L */
2117             sv_setpvs(GvSVn(gv),"\f");
2118             break;
2119         case ';':               /* $; */
2120             sv_setpvs(GvSVn(gv),"\034");
2121             break;
2122         case ']':               /* $] */
2123         {
2124             SV * const sv = GvSV(gv);
2125             if (!sv_derived_from(PL_patchlevel, "version"))
2126                 upg_version(PL_patchlevel, TRUE);
2127             GvSV(gv) = vnumify(PL_patchlevel);
2128             SvREADONLY_on(GvSV(gv));
2129             SvREFCNT_dec(sv);
2130         }
2131         break;
2132         case '\026':    /* $^V */
2133         {
2134             SV * const sv = GvSV(gv);
2135             GvSV(gv) = new_version(PL_patchlevel);
2136             SvREADONLY_on(GvSV(gv));
2137             SvREFCNT_dec(sv);
2138         }
2139         break;
2140         case 'a':
2141         case 'b':
2142             if (sv_type == SVt_PV)
2143                 GvMULTI_on(gv);
2144         }
2145     }
2146
2147     return addmg;
2148 }
2149
2150 /* This function is called when the stash already holds the GV of the magic
2151  * variable we're looking for, but we need to check that it has the correct
2152  * kind of magic.  For example, if someone first uses $! and then %!, the
2153  * latter would end up here, and we add the Errno tie to the HASH slot of
2154  * the *! glob.
2155  */
2156 PERL_STATIC_INLINE void
2157 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2158 {
2159     PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2160
2161     if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2162         if (*name == '!')
2163             require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
2164         else if (*name == '-' || *name == '+')
2165             require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
2166     } else if (sv_type == SVt_PV) {
2167         if (*name == '*' || *name == '#') {
2168             /* diag_listed_as: $* is no longer supported */
2169             Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
2170                                              WARN_SYNTAX),
2171                              "$%c is no longer supported", *name);
2172         }
2173     }
2174     if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2175       switch (*name) {
2176       case '[':
2177           require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
2178           break;
2179 #ifdef PERL_SAWAMPERSAND
2180       case '`':
2181           PL_sawampersand |= SAWAMPERSAND_LEFT;
2182           (void)GvSVn(gv);
2183           break;
2184       case '&':
2185           PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2186           (void)GvSVn(gv);
2187           break;
2188       case '\'':
2189           PL_sawampersand |= SAWAMPERSAND_RIGHT;
2190           (void)GvSVn(gv);
2191           break;
2192 #endif
2193       }
2194     }
2195 }
2196
2197 GV *
2198 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2199                        const svtype sv_type)
2200 {
2201     const char *name = nambeg;
2202     GV *gv = NULL;
2203     GV**gvp;
2204     STRLEN len;
2205     HV *stash = NULL;
2206     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2207     const I32 no_expand = flags & GV_NOEXPAND;
2208     const I32 add = flags & ~GV_NOADD_MASK;
2209     const U32 is_utf8 = flags & SVf_UTF8;
2210     bool addmg = cBOOL(flags & GV_ADDMG);
2211     const char *const name_end = nambeg + full_len;
2212     U32 faking_it;
2213
2214     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2215
2216      /* If we have GV_NOTQUAL, the caller promised that
2217       * there is no stash, so we can skip the check.
2218       * Similarly if full_len is 0, since then we're
2219       * dealing with something like *{""} or ""->foo()
2220       */
2221     if ((flags & GV_NOTQUAL) || !full_len) {
2222         len = full_len;
2223     }
2224     else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2225         if (name == name_end) return gv;
2226     }
2227     else {
2228         return NULL;
2229     }
2230
2231     if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2232         return NULL;
2233     }
2234
2235     /* By this point we should have a stash and a name */
2236     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2237     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2238         if (addmg) gv = (GV *)newSV(0);
2239         else return NULL;
2240     }
2241     else gv = *gvp, addmg = 0;
2242     /* From this point on, addmg means gv has not been inserted in the
2243        symtab yet. */
2244
2245     if (SvTYPE(gv) == SVt_PVGV) {
2246         /* The GV already exists, so return it, but check if we need to do
2247          * anything else with it before that.
2248          */
2249         if (add) {
2250             /* This is the heuristic that handles if a variable triggers the
2251              * 'used only once' warning.  If there's already a GV in the stash
2252              * with this name, then we assume that the variable has been used
2253              * before and turn its MULTI flag on.
2254              * It's a heuristic because it can easily be "tricked", like with
2255              * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2256              * not warning about $main::foo being used just once
2257              */
2258             GvMULTI_on(gv);
2259             gv_init_svtype(gv, sv_type);
2260             /* You reach this path once the typeglob has already been created,
2261                either by the same or a different sigil.  If this path didn't
2262                exist, then (say) referencing $! first, and %! second would
2263                mean that %! was not handled correctly.  */
2264             if (len == 1 && stash == PL_defstash) {
2265                 maybe_multimagic_gv(gv, name, sv_type);
2266             }
2267             else if (len == 3 && sv_type == SVt_PVAV
2268                   && strnEQ(name, "ISA", 3)
2269                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2270                 gv_magicalize_isa(gv);
2271         }
2272         return gv;
2273     } else if (no_init) {
2274         assert(!addmg);
2275         return gv;
2276     }
2277     /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2278      * don't expand it to a glob. This is an optimization so that things
2279      * copying constants over, like Exporter, don't have to be rewritten
2280      * to take into account that you can store more than just globs in
2281      * stashes.
2282      */
2283     else if (no_expand && SvROK(gv)) {
2284         assert(!addmg);
2285         return gv;
2286     }
2287
2288     /* Adding a new symbol.
2289        Unless of course there was already something non-GV here, in which case
2290        we want to behave as if there was always a GV here, containing some sort
2291        of subroutine.
2292        Otherwise we run the risk of creating things like GvIO, which can cause
2293        subtle bugs. eg the one that tripped up SQL::Translator  */
2294
2295     faking_it = SvOK(gv);
2296
2297     if (add & GV_ADDWARN)
2298         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2299                 "Had to create %"UTF8f" unexpectedly",
2300                  UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2301     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2302
2303     if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) )
2304         GvMULTI_on(gv) ;
2305
2306     /* First, store the gv in the symtab if we're adding magic,
2307      * but only for non-empty GVs
2308      */
2309 #define GvEMPTY(gv)      !(GvAV(gv) || GvHV(gv) || GvIO(gv) \
2310                         || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv))))
2311
2312     if ( addmg && !GvEMPTY(gv) ) {
2313         (void)hv_store(stash,name,len,(SV *)gv,0);
2314     }
2315
2316     /* set up magic where warranted */
2317     if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) {
2318         /* See 23496c6 */
2319         if (GvEMPTY(gv)) {
2320             if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) {
2321                 /* The GV was and still is "empty", except that now
2322                  * it has the magic flags turned on, so we want it
2323                  * stored in the symtab.
2324                  */
2325                 (void)hv_store(stash,name,len,(SV *)gv,0);
2326             }
2327             else {
2328                 /* Most likely the temporary GV created above */
2329                 SvREFCNT_dec_NN(gv);
2330                 gv = NULL;
2331             }
2332         }
2333     }
2334
2335     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2336     return gv;
2337 }
2338
2339 void
2340 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2341 {
2342     const char *name;
2343     const HV * const hv = GvSTASH(gv);
2344
2345     PERL_ARGS_ASSERT_GV_FULLNAME4;
2346
2347     sv_setpv(sv, prefix ? prefix : "");
2348
2349     if (hv && (name = HvNAME(hv))) {
2350       const STRLEN len = HvNAMELEN(hv);
2351       if (keepmain || strnNE(name, "main", len)) {
2352         sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2353         sv_catpvs(sv,"::");
2354       }
2355     }
2356     else sv_catpvs(sv,"__ANON__::");
2357     sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2358 }
2359
2360 void
2361 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2362 {
2363     const GV * const egv = GvEGVx(gv);
2364
2365     PERL_ARGS_ASSERT_GV_EFULLNAME4;
2366
2367     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2368 }
2369
2370
2371 /* recursively scan a stash and any nested stashes looking for entries
2372  * that need the "only used once" warning raised
2373  */
2374
2375 void
2376 Perl_gv_check(pTHX_ HV *stash)
2377 {
2378     I32 i;
2379
2380     PERL_ARGS_ASSERT_GV_CHECK;
2381
2382     if (!HvARRAY(stash))
2383         return;
2384
2385     assert(SvOOK(stash));
2386
2387     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2388         const HE *entry;
2389         /* mark stash is being scanned, to avoid recursing */
2390         HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2391         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2392             GV *gv;
2393             HV *hv;
2394             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2395                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2396             {
2397                 if (hv != PL_defstash && hv != stash
2398                     && !(SvOOK(hv)
2399                         && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2400                 )
2401                      gv_check(hv);              /* nested package */
2402             }
2403             else if ( *HeKEY(entry) != '_'
2404                         && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2405                 const char *file;
2406                 gv = MUTABLE_GV(HeVAL(entry));
2407                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2408                     continue;
2409                 file = GvFILE(gv);
2410                 CopLINE_set(PL_curcop, GvLINE(gv));
2411 #ifdef USE_ITHREADS
2412                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
2413 #else
2414                 CopFILEGV(PL_curcop)
2415                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2416 #endif
2417                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2418                         "Name \"%"HEKf"::%"HEKf
2419                         "\" used only once: possible typo",
2420                             HEKfARG(HvNAME_HEK(stash)),
2421                             HEKfARG(GvNAME_HEK(gv)));
2422             }
2423         }
2424         HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2425     }
2426 }
2427
2428 GV *
2429 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2430 {
2431     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2432     assert(!(flags & ~SVf_UTF8));
2433
2434     return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
2435                                 UTF8fARG(flags, strlen(pack), pack),
2436                                 (long)PL_gensym++),
2437                       GV_ADD, SVt_PVGV);
2438 }
2439
2440 /* hopefully this is only called on local symbol table entries */
2441
2442 GP*
2443 Perl_gp_ref(pTHX_ GP *gp)
2444 {
2445     if (!gp)
2446         return NULL;
2447     gp->gp_refcnt++;
2448     if (gp->gp_cv) {
2449         if (gp->gp_cvgen) {
2450             /* If the GP they asked for a reference to contains
2451                a method cache entry, clear it first, so that we
2452                don't infect them with our cached entry */
2453             SvREFCNT_dec_NN(gp->gp_cv);
2454             gp->gp_cv = NULL;
2455             gp->gp_cvgen = 0;
2456         }
2457     }
2458     return gp;
2459 }
2460
2461 void
2462 Perl_gp_free(pTHX_ GV *gv)
2463 {
2464     GP* gp;
2465     int attempts = 100;
2466
2467     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2468         return;
2469     if (gp->gp_refcnt == 0) {
2470         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2471                          "Attempt to free unreferenced glob pointers"
2472                          pTHX__FORMAT pTHX__VALUE);
2473         return;
2474     }
2475     if (gp->gp_refcnt > 1) {
2476        borrowed:
2477         if (gp->gp_egv == gv)
2478             gp->gp_egv = 0;
2479         gp->gp_refcnt--;
2480         GvGP_set(gv, NULL);
2481         return;
2482     }
2483
2484     while (1) {
2485       /* Copy and null out all the glob slots, so destructors do not see
2486          freed SVs. */
2487       HEK * const file_hek = gp->gp_file_hek;
2488       SV  * const sv       = gp->gp_sv;
2489       AV  * const av       = gp->gp_av;
2490       HV  * const hv       = gp->gp_hv;
2491       IO  * const io       = gp->gp_io;
2492       CV  * const cv       = gp->gp_cv;
2493       CV  * const form     = gp->gp_form;
2494
2495       gp->gp_file_hek = NULL;
2496       gp->gp_sv       = NULL;
2497       gp->gp_av       = NULL;
2498       gp->gp_hv       = NULL;
2499       gp->gp_io       = NULL;
2500       gp->gp_cv       = NULL;
2501       gp->gp_form     = NULL;
2502
2503       if (file_hek)
2504         unshare_hek(file_hek);
2505
2506       SvREFCNT_dec(sv);
2507       SvREFCNT_dec(av);
2508       /* FIXME - another reference loop GV -> symtab -> GV ?
2509          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2510       if (hv && SvTYPE(hv) == SVt_PVHV) {
2511         const HEK *hvname_hek = HvNAME_HEK(hv);
2512         DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", HEKfARG(hvname_hek)));
2513         if (PL_stashcache && hvname_hek)
2514            (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2515         SvREFCNT_dec(hv);
2516       }
2517       SvREFCNT_dec(io);
2518       SvREFCNT_dec(cv);
2519       SvREFCNT_dec(form);
2520
2521       /* Possibly reallocated by a destructor */
2522       gp = GvGP(gv);
2523
2524       if (!gp->gp_file_hek
2525        && !gp->gp_sv
2526        && !gp->gp_av
2527        && !gp->gp_hv
2528        && !gp->gp_io
2529        && !gp->gp_cv
2530        && !gp->gp_form) break;
2531
2532       if (--attempts == 0) {
2533         Perl_die(aTHX_
2534           "panic: gp_free failed to free glob pointer - "
2535           "something is repeatedly re-creating entries"
2536         );
2537       }
2538     }
2539
2540     /* Possibly incremented by a destructor doing glob assignment */
2541     if (gp->gp_refcnt > 1) goto borrowed;
2542     Safefree(gp);
2543     GvGP_set(gv, NULL);
2544 }
2545
2546 int
2547 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2548 {
2549     AMT * const amtp = (AMT*)mg->mg_ptr;
2550     PERL_UNUSED_ARG(sv);
2551
2552     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2553
2554     if (amtp && AMT_AMAGIC(amtp)) {
2555         int i;
2556         for (i = 1; i < NofAMmeth; i++) {
2557             CV * const cv = amtp->table[i];
2558             if (cv) {
2559                 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2560                 amtp->table[i] = NULL;
2561             }
2562         }
2563     }
2564  return 0;
2565 }
2566
2567 /* Updates and caches the CV's */
2568 /* Returns:
2569  * 1 on success and there is some overload
2570  * 0 if there is no overload
2571  * -1 if some error occurred and it couldn't croak
2572  */
2573
2574 int
2575 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2576 {
2577   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2578   AMT amt;
2579   const struct mro_meta* stash_meta = HvMROMETA(stash);
2580   U32 newgen;
2581
2582   PERL_ARGS_ASSERT_GV_AMUPDATE;
2583
2584   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2585   if (mg) {
2586       const AMT * const amtp = (AMT*)mg->mg_ptr;
2587       if (amtp->was_ok_sub == newgen) {
2588           return AMT_AMAGIC(amtp) ? 1 : 0;
2589       }
2590       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2591   }
2592
2593   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2594
2595   Zero(&amt,1,AMT);
2596   amt.was_ok_sub = newgen;
2597   amt.fallback = AMGfallNO;
2598   amt.flags = 0;
2599
2600   {
2601     int filled = 0;
2602     int i;
2603     bool deref_seen = 0;
2604
2605
2606     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2607
2608     /* Try to find via inheritance. */
2609     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2610     SV * const sv = gv ? GvSV(gv) : NULL;
2611     CV* cv;
2612
2613     if (!gv)
2614     {
2615       if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2616         goto no_table;
2617     }
2618 #ifdef PERL_DONT_CREATE_GVSV
2619     else if (!sv) {
2620         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2621     }
2622 #endif
2623     else if (SvTRUE(sv))
2624         /* don't need to set overloading here because fallback => 1
2625          * is the default setting for classes without overloading */
2626         amt.fallback=AMGfallYES;
2627     else if (SvOK(sv)) {
2628         amt.fallback=AMGfallNEVER;
2629         filled = 1;
2630     }
2631     else {
2632         filled = 1;
2633     }
2634
2635     assert(SvOOK(stash));
2636     /* initially assume the worst */
2637     HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
2638
2639     for (i = 1; i < NofAMmeth; i++) {
2640         const char * const cooky = PL_AMG_names[i];
2641         /* Human-readable form, for debugging: */
2642         const char * const cp = AMG_id2name(i);
2643         const STRLEN l = PL_AMG_namelens[i];
2644
2645         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2646                      cp, HvNAME_get(stash)) );
2647         /* don't fill the cache while looking up!
2648            Creation of inheritance stubs in intermediate packages may
2649            conflict with the logic of runtime method substitution.
2650            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2651            then we could have created stubs for "(+0" in A and C too.
2652            But if B overloads "bool", we may want to use it for
2653            numifying instead of C's "+0". */
2654         gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2655         cv = 0;
2656         if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
2657             const HEK * const gvhek =
2658                 CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(cv));
2659             const HEK * const stashek =
2660                 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
2661             if (HEK_LEN(gvhek) == 3 && strEQ(HEK_KEY(gvhek), "nil")
2662              && stashek && HEK_LEN(stashek) == 8
2663              && strEQ(HEK_KEY(stashek), "overload")) {
2664                 /* This is a hack to support autoloading..., while
2665                    knowing *which* methods were declared as overloaded. */
2666                 /* GvSV contains the name of the method. */
2667                 GV *ngv = NULL;
2668                 SV *gvsv = GvSV(gv);
2669
2670                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2671                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2672                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2673                 if (!gvsv || !SvPOK(gvsv)
2674                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2675                 {
2676                     /* Can be an import stub (created by "can"). */
2677                     if (destructing) {
2678                         return -1;
2679                     }
2680                     else {
2681                         const SV * const name = (gvsv && SvPOK(gvsv))
2682                                                     ? gvsv
2683                                                     : newSVpvs_flags("???", SVs_TEMP);
2684                         /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2685                         Perl_croak(aTHX_ "%s method \"%"SVf256
2686                                     "\" overloading \"%s\" "\
2687                                     "in package \"%"HEKf256"\"",
2688                                    (GvCVGEN(gv) ? "Stub found while resolving"
2689                                     : "Can't resolve"),
2690                                    SVfARG(name), cp,
2691                                    HEKfARG(
2692                                         HvNAME_HEK(stash)
2693                                    ));
2694                     }
2695                 }
2696                 cv = GvCV(gv = ngv);
2697             }
2698             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2699                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2700                          GvNAME(CvGV(cv))) );
2701             filled = 1;
2702         } else if (gv) {                /* Autoloaded... */
2703             cv = MUTABLE_CV(gv);
2704             filled = 1;
2705         }
2706         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2707
2708         if (gv) {
2709             switch (i) {
2710             case to_sv_amg:
2711             case to_av_amg:
2712             case to_hv_amg:
2713             case to_gv_amg:
2714             case to_cv_amg:
2715             case nomethod_amg:
2716                 deref_seen = 1;
2717                 break;
2718             }
2719         }
2720     }
2721     if (!deref_seen)
2722         /* none of @{} etc overloaded; we can do $obj->[N] quicker.
2723          * NB - aux var invalid here, HvARRAY() could have been
2724          * reallocated since it was assigned to */
2725         HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
2726
2727     if (filled) {
2728       AMT_AMAGIC_on(&amt);
2729       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2730                                                 (char*)&amt, sizeof(AMT));
2731       return TRUE;
2732     }
2733   }
2734   /* Here we have no table: */
2735  no_table:
2736   AMT_AMAGIC_off(&amt);
2737   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2738                                                 (char*)&amt, sizeof(AMTS));
2739   return 0;
2740 }
2741
2742
2743 CV*
2744 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2745 {
2746     MAGIC *mg;
2747     AMT *amtp;
2748     U32 newgen;
2749     struct mro_meta* stash_meta;
2750
2751     if (!stash || !HvNAME_get(stash))
2752         return NULL;
2753
2754     stash_meta = HvMROMETA(stash);
2755     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2756
2757     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2758     if (!mg) {
2759       do_update:
2760         if (Gv_AMupdate(stash, 0) == -1)
2761             return NULL;
2762         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2763     }
2764     assert(mg);
2765     amtp = (AMT*)mg->mg_ptr;
2766     if ( amtp->was_ok_sub != newgen )
2767         goto do_update;
2768     if (AMT_AMAGIC(amtp)) {
2769         CV * const ret = amtp->table[id];
2770         if (ret && isGV(ret)) {         /* Autoloading stab */
2771             /* Passing it through may have resulted in a warning
2772                "Inherited AUTOLOAD for a non-method deprecated", since
2773                our caller is going through a function call, not a method call.
2774                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2775             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2776
2777             if (gv && GvCV(gv))
2778                 return GvCV(gv);
2779         }
2780         return ret;
2781     }
2782
2783     return NULL;
2784 }
2785
2786
2787 /* Implement tryAMAGICun_MG macro.
2788    Do get magic, then see if the stack arg is overloaded and if so call it.
2789    Flags:
2790         AMGf_set     return the arg using SETs rather than assigning to
2791                      the targ
2792         AMGf_numeric apply sv_2num to the stack arg.
2793 */
2794
2795 bool
2796 Perl_try_amagic_un(pTHX_ int method, int flags) {
2797     dSP;
2798     SV* tmpsv;
2799     SV* const arg = TOPs;
2800
2801     SvGETMAGIC(arg);
2802
2803     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2804                                               AMGf_noright | AMGf_unary))) {
2805         if (flags & AMGf_set) {
2806             SETs(tmpsv);
2807         }
2808         else {
2809             dTARGET;
2810             if (SvPADMY(TARG)) {
2811                 sv_setsv(TARG, tmpsv);
2812                 SETTARG;
2813             }
2814             else
2815                 SETs(tmpsv);
2816         }
2817         PUTBACK;
2818         return TRUE;
2819     }
2820
2821     if ((flags & AMGf_numeric) && SvROK(arg))
2822         *sp = sv_2num(arg);
2823     return FALSE;
2824 }
2825
2826
2827 /* Implement tryAMAGICbin_MG macro.
2828    Do get magic, then see if the two stack args are overloaded and if so
2829    call it.
2830    Flags:
2831         AMGf_set     return the arg using SETs rather than assigning to
2832                      the targ
2833         AMGf_assign  op may be called as mutator (eg +=)
2834         AMGf_numeric apply sv_2num to the stack arg.
2835 */
2836
2837 bool
2838 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2839     dSP;
2840     SV* const left = TOPm1s;
2841     SV* const right = TOPs;
2842
2843     SvGETMAGIC(left);
2844     if (left != right)
2845         SvGETMAGIC(right);
2846
2847     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2848         SV * const tmpsv = amagic_call(left, right, method,
2849                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2850         if (tmpsv) {
2851             if (flags & AMGf_set) {
2852                 (void)POPs;
2853                 SETs(tmpsv);
2854             }
2855             else {
2856                 dATARGET;
2857                 (void)POPs;
2858                 if (opASSIGN || SvPADMY(TARG)) {
2859                     sv_setsv(TARG, tmpsv);
2860                     SETTARG;
2861                 }
2862                 else
2863                     SETs(tmpsv);
2864             }
2865             PUTBACK;
2866             return TRUE;
2867         }
2868     }
2869     if(left==right && SvGMAGICAL(left)) {
2870         SV * const left = sv_newmortal();
2871         *(sp-1) = left;
2872         /* Print the uninitialized warning now, so it includes the vari-
2873            able name. */
2874         if (!SvOK(right)) {
2875             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2876             sv_setsv_flags(left, &PL_sv_no, 0);
2877         }
2878         else sv_setsv_flags(left, right, 0);
2879         SvGETMAGIC(right);
2880     }
2881     if (flags & AMGf_numeric) {
2882         if (SvROK(TOPm1s))
2883             *(sp-1) = sv_2num(TOPm1s);
2884         if (SvROK(right))
2885             *sp     = sv_2num(right);
2886     }
2887     return FALSE;
2888 }
2889
2890 SV *
2891 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2892     SV *tmpsv = NULL;
2893     HV *stash;
2894
2895     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2896
2897     if (!SvAMAGIC(ref))
2898         return ref;
2899     /* return quickly if none of the deref ops are overloaded */
2900     stash = SvSTASH(SvRV(ref));
2901     assert(SvOOK(stash));
2902     if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
2903         return ref;
2904
2905     while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
2906                                 AMGf_noright | AMGf_unary))) {
2907         if (!SvROK(tmpsv))
2908             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2909         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2910             /* Bail out if it returns us the same reference.  */
2911             return tmpsv;
2912         }
2913         ref = tmpsv;
2914         if (!SvAMAGIC(ref))
2915             break;
2916     }
2917     return tmpsv ? tmpsv : ref;
2918 }
2919
2920 bool
2921 Perl_amagic_is_enabled(pTHX_ int method)
2922 {
2923       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2924
2925       assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2926
2927       if ( !lex_mask || !SvOK(lex_mask) )
2928           /* overloading lexically disabled */
2929           return FALSE;
2930       else if ( lex_mask && SvPOK(lex_mask) ) {
2931           /* we have an entry in the hints hash, check if method has been
2932            * masked by overloading.pm */
2933           STRLEN len;
2934           const int offset = method / 8;
2935           const int bit    = method % 8;
2936           char *pv = SvPV(lex_mask, len);
2937
2938           /* Bit set, so this overloading operator is disabled */
2939           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2940               return FALSE;
2941       }
2942       return TRUE;
2943 }
2944
2945 SV*
2946 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2947 {
2948   dVAR;
2949   MAGIC *mg;
2950   CV *cv=NULL;
2951   CV **cvp=NULL, **ocvp=NULL;
2952   AMT *amtp=NULL, *oamtp=NULL;
2953   int off = 0, off1, lr = 0, notfound = 0;
2954   int postpr = 0, force_cpy = 0;
2955   int assign = AMGf_assign & flags;
2956   const int assignshift = assign ? 1 : 0;
2957   int use_default_op = 0;
2958   int force_scalar = 0;
2959 #ifdef DEBUGGING
2960   int fl=0;
2961 #endif
2962   HV* stash=NULL;
2963
2964   PERL_ARGS_ASSERT_AMAGIC_CALL;
2965
2966   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2967       if (!amagic_is_enabled(method)) return NULL;
2968   }
2969
2970   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2971       && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
2972       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2973       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2974                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2975                         : NULL))
2976       && ((cv = cvp[off=method+assignshift])
2977           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2978                                                           * usual method */
2979                   (
2980 #ifdef DEBUGGING
2981                    fl = 1,
2982 #endif
2983                    cv = cvp[off=method])))) {
2984     lr = -1;                    /* Call method for left argument */
2985   } else {
2986     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2987       int logic;
2988
2989       /* look for substituted methods */
2990       /* In all the covered cases we should be called with assign==0. */
2991          switch (method) {
2992          case inc_amg:
2993            force_cpy = 1;
2994            if ((cv = cvp[off=add_ass_amg])
2995                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2996              right = &PL_sv_yes; lr = -1; assign = 1;
2997            }
2998            break;
2999          case dec_amg:
3000            force_cpy = 1;
3001            if ((cv = cvp[off = subtr_ass_amg])
3002                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3003              right = &PL_sv_yes; lr = -1; assign = 1;
3004            }
3005            break;
3006          case bool__amg:
3007            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
3008            break;
3009          case numer_amg:
3010            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
3011            break;
3012          case string_amg:
3013            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
3014            break;
3015          case not_amg:
3016            (void)((cv = cvp[off=bool__amg])
3017                   || (cv = cvp[off=numer_amg])
3018                   || (cv = cvp[off=string_amg]));
3019            if (cv)
3020                postpr = 1;
3021            break;
3022          case copy_amg:
3023            {
3024              /*
3025                   * SV* ref causes confusion with the interpreter variable of
3026                   * the same name
3027                   */
3028              SV* const tmpRef=SvRV(left);
3029              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
3030                 /*
3031                  * Just to be extra cautious.  Maybe in some
3032                  * additional cases sv_setsv is safe, too.
3033                  */
3034                 SV* const newref = newSVsv(tmpRef);
3035                 SvOBJECT_on(newref);
3036                 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
3037                    delegate to the stash. */
3038                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
3039                 return newref;
3040              }
3041            }
3042            break;
3043          case abs_amg:
3044            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3045                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
3046              SV* const nullsv=sv_2mortal(newSViv(0));
3047              if (off1==lt_amg) {
3048                SV* const lessp = amagic_call(left,nullsv,
3049                                        lt_amg,AMGf_noright);
3050                logic = SvTRUE(lessp);
3051              } else {
3052                SV* const lessp = amagic_call(left,nullsv,
3053                                        ncmp_amg,AMGf_noright);
3054                logic = (SvNV(lessp) < 0);
3055              }
3056              if (logic) {
3057                if (off==subtr_amg) {
3058                  right = left;
3059                  left = nullsv;
3060                  lr = 1;
3061                }
3062              } else {
3063                return left;
3064              }
3065            }
3066            break;
3067          case neg_amg:
3068            if ((cv = cvp[off=subtr_amg])) {
3069              right = left;
3070              left = sv_2mortal(newSViv(0));
3071              lr = 1;
3072            }
3073            break;
3074          case int_amg:
3075          case iter_amg:                 /* XXXX Eventually should do to_gv. */
3076          case ftest_amg:                /* XXXX Eventually should do to_gv. */
3077          case regexp_amg:
3078              /* FAIL safe */
3079              return NULL;       /* Delegate operation to standard mechanisms. */
3080
3081          case to_sv_amg:
3082          case to_av_amg:
3083          case to_hv_amg:
3084          case to_gv_amg:
3085          case to_cv_amg:
3086              /* FAIL safe */
3087              return left;       /* Delegate operation to standard mechanisms. */
3088
3089          default:
3090            goto not_found;
3091          }
3092          if (!cv) goto not_found;
3093     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3094                && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3095                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3096                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3097                           ? (amtp = (AMT*)mg->mg_ptr)->table
3098                           : NULL))
3099                && (cv = cvp[off=method])) { /* Method for right
3100                                              * argument found */
3101       lr=1;
3102     } else if (((cvp && amtp->fallback > AMGfallNEVER)
3103                 || (ocvp && oamtp->fallback > AMGfallNEVER))
3104                && !(flags & AMGf_unary)) {
3105                                 /* We look for substitution for
3106                                  * comparison operations and
3107                                  * concatenation */
3108       if (method==concat_amg || method==concat_ass_amg
3109           || method==repeat_amg || method==repeat_ass_amg) {
3110         return NULL;            /* Delegate operation to string conversion */
3111       }
3112       off = -1;
3113       switch (method) {
3114          case lt_amg:
3115          case le_amg:
3116          case gt_amg:
3117          case ge_amg:
3118          case eq_amg:
3119          case ne_amg:
3120              off = ncmp_amg;
3121              break;
3122          case slt_amg:
3123          case sle_amg:
3124          case sgt_amg:
3125          case sge_amg:
3126          case seq_amg:
3127          case sne_amg:
3128              off = scmp_amg;
3129              break;
3130          }
3131       if (off != -1) {
3132           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3133               cv = ocvp[off];
3134               lr = -1;
3135           }
3136           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3137               cv = cvp[off];
3138               lr = 1;
3139           }
3140       }
3141       if (cv)
3142           postpr = 1;
3143       else
3144           goto not_found;
3145     } else {
3146     not_found:                  /* No method found, either report or croak */
3147       switch (method) {
3148          case to_sv_amg:
3149          case to_av_amg:
3150          case to_hv_amg:
3151          case to_gv_amg:
3152          case to_cv_amg:
3153              /* FAIL safe */
3154              return left;       /* Delegate operation to standard mechanisms. */
3155       }
3156       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3157         notfound = 1; lr = -1;
3158       } else if (cvp && (cv=cvp[nomethod_amg])) {
3159         notfound = 1; lr = 1;
3160       } else if ((use_default_op =
3161                   (!ocvp || oamtp->fallback >= AMGfallYES)
3162                   && (!cvp || amtp->fallback >= AMGfallYES))
3163                  && !DEBUG_o_TEST) {
3164         /* Skip generating the "no method found" message.  */
3165         return NULL;
3166       } else {
3167         SV *msg;
3168         if (off==-1) off=method;
3169         msg = sv_2mortal(Perl_newSVpvf(aTHX_
3170                       "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
3171                       AMG_id2name(method + assignshift),
3172                       (flags & AMGf_unary ? " " : "\n\tleft "),
3173                       SvAMAGIC(left)?
3174                         "in overloaded package ":
3175                         "has no overloaded magic",
3176                       SvAMAGIC(left)?
3177                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3178                         SVfARG(&PL_sv_no),
3179                       SvAMAGIC(right)?
3180                         ",\n\tright argument in overloaded package ":
3181                         (flags & AMGf_unary
3182                          ? ""
3183                          : ",\n\tright argument has no overloaded magic"),
3184                       SvAMAGIC(right)?
3185                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3186                         SVfARG(&PL_sv_no)));
3187         if (use_default_op) {
3188           DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
3189         } else {
3190           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
3191         }
3192         return NULL;
3193       }
3194       force_cpy = force_cpy || assign;
3195     }
3196   }
3197
3198   switch (method) {
3199     /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3200      * operation. we need this to return a value, so that it can be assigned
3201      * later on, in the postpr block (case inc_amg/dec_amg), even if the
3202      * increment or decrement was itself called in void context */
3203     case inc_amg:
3204       if (off == add_amg)
3205         force_scalar = 1;
3206       break;
3207     case dec_amg:
3208       if (off == subtr_amg)
3209         force_scalar = 1;
3210       break;
3211     /* in these cases, we're calling an assignment variant of an operator
3212      * (+= rather than +, for instance). regardless of whether it's a
3213      * fallback or not, it always has to return a value, which will be
3214      * assigned to the proper variable later */
3215     case add_amg:
3216     case subtr_amg:
3217     case mult_amg:
3218     case div_amg:
3219     case modulo_amg:
3220     case pow_amg:
3221     case lshift_amg:
3222     case rshift_amg:
3223     case repeat_amg:
3224     case concat_amg:
3225     case band_amg:
3226     case bor_amg:
3227     case bxor_amg:
3228       if (assign)
3229         force_scalar = 1;
3230       break;
3231     /* the copy constructor always needs to return a value */
3232     case copy_amg:
3233       force_scalar = 1;
3234       break;
3235     /* because of the way these are implemented (they don't perform the
3236      * dereferencing themselves, they return a reference that perl then
3237      * dereferences later), they always have to be in scalar context */
3238     case to_sv_amg:
3239     case to_av_amg:
3240     case to_hv_amg:
3241     case to_gv_amg:
3242     case to_cv_amg:
3243       force_scalar = 1;
3244       break;
3245     /* these don't have an op of their own; they're triggered by their parent
3246      * op, so the context there isn't meaningful ('$a and foo()' in void
3247      * context still needs to pass scalar context on to $a's bool overload) */
3248     case bool__amg:
3249     case numer_amg:
3250     case string_amg:
3251       force_scalar = 1;
3252       break;
3253   }
3254
3255 #ifdef DEBUGGING
3256   if (!notfound) {
3257     DEBUG_o(Perl_deb(aTHX_
3258                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
3259                      AMG_id2name(off),
3260                      method+assignshift==off? "" :
3261                      " (initially \"",
3262                      method+assignshift==off? "" :
3263                      AMG_id2name(method+assignshift),
3264                      method+assignshift==off? "" : "\")",
3265                      flags & AMGf_unary? "" :
3266                      lr==1 ? " for right argument": " for left argument",
3267                      flags & AMGf_unary? " for argument" : "",
3268                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3269                      fl? ",\n\tassignment variant used": "") );
3270   }
3271 #endif
3272     /* Since we use shallow copy during assignment, we need
3273      * to dublicate the contents, probably calling user-supplied
3274      * version of copy operator
3275      */
3276     /* We need to copy in following cases:
3277      * a) Assignment form was called.
3278      *          assignshift==1,  assign==T, method + 1 == off
3279      * b) Increment or decrement, called directly.
3280      *          assignshift==0,  assign==0, method + 0 == off
3281      * c) Increment or decrement, translated to assignment add/subtr.
3282      *          assignshift==0,  assign==T,
3283      *          force_cpy == T
3284      * d) Increment or decrement, translated to nomethod.
3285      *          assignshift==0,  assign==0,
3286      *          force_cpy == T
3287      * e) Assignment form translated to nomethod.
3288      *          assignshift==1,  assign==T, method + 1 != off
3289      *          force_cpy == T
3290      */
3291     /*  off is method, method+assignshift, or a result of opcode substitution.
3292      *  In the latter case assignshift==0, so only notfound case is important.
3293      */
3294   if ( (lr == -1) && ( ( (method + assignshift == off)
3295         && (assign || (method == inc_amg) || (method == dec_amg)))
3296       || force_cpy) )
3297   {
3298       /* newSVsv does not behave as advertised, so we copy missing
3299        * information by hand */
3300       SV *tmpRef = SvRV(left);
3301       SV *rv_copy;
3302       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3303           SvRV_set(left, rv_copy);
3304           SvSETMAGIC(left);
3305           SvREFCNT_dec_NN(tmpRef);
3306       }
3307   }
3308
3309   {
3310     dSP;
3311     BINOP myop;
3312     SV* res;
3313     const bool oldcatch = CATCH_GET;
3314     I32 oldmark, nret;
3315     int gimme = force_scalar ? G_SCALAR : GIMME_V;
3316
3317     CATCH_SET(TRUE);
3318     Zero(&myop, 1, BINOP);
3319     myop.op_last = (OP *) &myop;
3320     myop.op_next = NULL;
3321     myop.op_flags = OPf_STACKED;
3322
3323     switch (gimme) {
3324         case G_VOID:
3325             myop.op_flags |= OPf_WANT_VOID;
3326             break;
3327         case G_ARRAY:
3328             if (flags & AMGf_want_list) {
3329                 myop.op_flags |= OPf_WANT_LIST;
3330                 break;
3331             }
3332             /* FALLTHROUGH */
3333         default:
3334             myop.op_flags |= OPf_WANT_SCALAR;
3335             break;
3336     }
3337
3338     PUSHSTACKi(PERLSI_OVERLOAD);
3339     ENTER;
3340     SAVEOP();
3341     PL_op = (OP *) &myop;
3342     if (PERLDB_SUB && PL_curstash != PL_debstash)
3343         PL_op->op_private |= OPpENTERSUB_DB;
3344     Perl_pp_pushmark(aTHX);
3345
3346     EXTEND(SP, notfound + 5);
3347     PUSHs(lr>0? right: left);
3348     PUSHs(lr>0? left: right);
3349     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3350     if (notfound) {
3351       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3352                            AMG_id2namelen(method + assignshift), SVs_TEMP));
3353     }
3354     PUSHs(MUTABLE_SV(cv));
3355     PUTBACK;
3356     oldmark = TOPMARK;
3357
3358     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3359       CALLRUNOPS(aTHX);
3360     LEAVE;
3361     SPAGAIN;
3362     nret = SP - (PL_stack_base + oldmark);
3363
3364     switch (gimme) {
3365         case G_VOID:
3366             /* returning NULL has another meaning, and we check the context
3367              * at the call site too, so this can be differentiated from the
3368              * scalar case */
3369             res = &PL_sv_undef;
3370             SP = PL_stack_base + oldmark;
3371             break;
3372         case G_ARRAY: {
3373             if (flags & AMGf_want_list) {
3374                 res = sv_2mortal((SV *)newAV());
3375                 av_extend((AV *)res, nret);
3376                 while (nret--)
3377                     av_store((AV *)res, nret, POPs);
3378                 break;
3379             }
3380             /* FALLTHROUGH */
3381         }
3382         default:
3383             res = POPs;
3384             break;
3385     }
3386
3387     PUTBACK;
3388     POPSTACK;
3389     CATCH_SET(oldcatch);
3390
3391     if (postpr) {
3392       int ans;
3393       switch (method) {
3394       case le_amg:
3395       case sle_amg:
3396         ans=SvIV(res)<=0; break;
3397       case lt_amg:
3398       case slt_amg:
3399         ans=SvIV(res)<0; break;
3400       case ge_amg:
3401       case sge_amg:
3402         ans=SvIV(res)>=0; break;
3403       case gt_amg:
3404       case sgt_amg:
3405         ans=SvIV(res)>0; break;
3406       case eq_amg:
3407       case seq_amg:
3408         ans=SvIV(res)==0; break;
3409       case ne_amg:
3410       case sne_amg:
3411         ans=SvIV(res)!=0; break;
3412       case inc_amg:
3413       case dec_amg:
3414         SvSetSV(left,res); return left;
3415       case not_amg:
3416         ans=!SvTRUE(res); break;
3417       default:
3418         ans=0; break;
3419       }
3420       return boolSV(ans);
3421     } else if (method==copy_amg) {
3422       if (!SvROK(res)) {
3423         Perl_croak(aTHX_ "Copy method did not return a reference");
3424       }
3425       return SvREFCNT_inc(SvRV(res));
3426     } else {
3427       return res;
3428     }
3429   }
3430 }
3431
3432 void
3433 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3434 {
3435     dVAR;
3436     U32 hash;
3437
3438     PERL_ARGS_ASSERT_GV_NAME_SET;
3439
3440     if (len > I32_MAX)
3441         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3442
3443     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3444         unshare_hek(GvNAME_HEK(gv));
3445     }
3446
3447     PERL_HASH(hash, name, len);
3448     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3449 }
3450
3451 /*
3452 =for apidoc gv_try_downgrade
3453
3454 If the typeglob C<gv> can be expressed more succinctly, by having
3455 something other than a real GV in its place in the stash, replace it
3456 with the optimised form.  Basic requirements for this are that C<gv>
3457 is a real typeglob, is sufficiently ordinary, and is only referenced
3458 from its package.  This function is meant to be used when a GV has been
3459 looked up in part to see what was there, causing upgrading, but based
3460 on what was found it turns out that the real GV isn't required after all.
3461
3462 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3463
3464 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3465 sub, the typeglob is replaced with a scalar-reference placeholder that
3466 more compactly represents the same thing.
3467
3468 =cut
3469 */
3470
3471 void
3472 Perl_gv_try_downgrade(pTHX_ GV *gv)
3473 {
3474     HV *stash;
3475     CV *cv;
3476     HEK *namehek;
3477     SV **gvp;
3478     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3479
3480     /* XXX Why and where does this leave dangling pointers during global
3481        destruction? */
3482     if (PL_phase == PERL_PHASE_DESTRUCT) return;
3483
3484     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3485             !SvOBJECT(gv) && !SvREADONLY(gv) &&
3486             isGV_with_GP(gv) && GvGP(gv) &&
3487             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3488             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3489             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3490         return;
3491     if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3492         return;
3493     if (SvMAGICAL(gv)) {
3494         MAGIC *mg;
3495         /* only backref magic is allowed */
3496         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3497             return;
3498         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3499             if (mg->mg_type != PERL_MAGIC_backref)
3500                 return;
3501         }
3502     }
3503     cv = GvCV(gv);
3504     if (!cv) {
3505         HEK *gvnhek = GvNAME_HEK(gv);
3506         (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3507     } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3508             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3509             CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
3510             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3511             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3512             (namehek = GvNAME_HEK(gv)) &&
3513             (gvp = hv_fetchhek(stash, namehek, 0)) &&
3514             *gvp == (SV*)gv) {
3515         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3516         const bool imported = !!GvIMPORTED_CV(gv);
3517         SvREFCNT(gv) = 0;
3518         sv_clear((SV*)gv);
3519         SvREFCNT(gv) = 1;
3520         SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3521         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3522                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3523         SvRV_set(gv, value);
3524     }
3525 }
3526
3527 GV *
3528 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3529 {
3530     GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3531     GV * const *gvp;
3532     PERL_ARGS_ASSERT_GV_OVERRIDE;
3533     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3534     gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3535     gv = gvp ? *gvp : NULL;
3536     if (gv && !isGV(gv)) {
3537         if (!SvPCS_IMPORTED(gv)) return NULL;
3538         gv_init(gv, PL_globalstash, name, len, 0);
3539         return gv;
3540     }
3541     return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3542 }
3543
3544 #include "XSUB.h"
3545
3546 static void
3547 core_xsub(pTHX_ CV* cv)
3548 {
3549     Perl_croak(aTHX_
3550        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3551     );
3552 }
3553
3554 /*
3555  * Local variables:
3556  * c-indentation-style: bsd
3557  * c-basic-offset: 4
3558  * indent-tabs-mode: nil
3559  * End:
3560  *
3561  * ex: set ts=8 sts=4 sw=4 et:
3562  */