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