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