gv.c

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