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