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     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 Flags may be one of:
1319
1320     GV_ADD
1321     SVf_UTF8
1322     GV_NOADD_NOINIT
1323     GV_NOINIT
1324     GV_NOEXPAND
1325     GV_ADDMG
1326
1327 The most important of which are probably GV_ADD and SVf_UTF8.
1328
1329 =cut
1330 */
1331
1332 HV*
1333 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1334 {
1335     char smallbuf[128];
1336     char *tmpbuf;
1337     HV *stash;
1338     GV *tmpgv;
1339     U32 tmplen = namelen + 2;
1340
1341     PERL_ARGS_ASSERT_GV_STASHPVN;
1342
1343     if (tmplen <= sizeof smallbuf)
1344         tmpbuf = smallbuf;
1345     else
1346         Newx(tmpbuf, tmplen, char);
1347     Copy(name, tmpbuf, namelen, char);
1348     tmpbuf[namelen]   = ':';
1349     tmpbuf[namelen+1] = ':';
1350     tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1351     if (tmpbuf != smallbuf)
1352         Safefree(tmpbuf);
1353     if (!tmpgv)
1354         return NULL;
1355     stash = GvHV(tmpgv);
1356     if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1357     assert(stash);
1358     if (!HvNAME_get(stash)) {
1359         hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1360
1361         /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1362         /* If the containing stash has multiple effective
1363            names, see that this one gets them, too. */
1364         if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1365             mro_package_moved(stash, NULL, tmpgv, 1);
1366     }
1367     return stash;
1368 }
1369
1370 /*
1371 =for apidoc gv_stashsv
1372
1373 Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
1374
1375 =cut
1376 */
1377
1378 HV*
1379 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1380 {
1381     STRLEN len;
1382     const char * const ptr = SvPV_const(sv,len);
1383
1384     PERL_ARGS_ASSERT_GV_STASHSV;
1385
1386     return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
1387 }
1388
1389
1390 GV *
1391 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1392     PERL_ARGS_ASSERT_GV_FETCHPV;
1393     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1394 }
1395
1396 GV *
1397 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1398     STRLEN len;
1399     const char * const nambeg =
1400        SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1401     PERL_ARGS_ASSERT_GV_FETCHSV;
1402     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1403 }
1404
1405 STATIC void
1406 S_gv_magicalize_isa(pTHX_ GV *gv)
1407 {
1408     AV* av;
1409
1410     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1411
1412     av = GvAVn(gv);
1413     GvMULTI_on(gv);
1414     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1415              NULL, 0);
1416 }
1417
1418 GV *
1419 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
1420                        const svtype sv_type)
1421 {
1422     dVAR;
1423     const char *name = nambeg;
1424     GV *gv = NULL;
1425     GV**gvp;
1426     I32 len;
1427     const char *name_cursor;
1428     HV *stash = NULL;
1429     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
1430     const I32 no_expand = flags & GV_NOEXPAND;
1431     const I32 add = flags & ~GV_NOADD_MASK;
1432     const U32 is_utf8 = flags & SVf_UTF8;
1433     bool addmg = !!(flags & GV_ADDMG);
1434     const char *const name_end = nambeg + full_len;
1435     const char *const name_em1 = name_end - 1;
1436     U32 faking_it;
1437
1438     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1439
1440     if (flags & GV_NOTQUAL) {
1441         /* Caller promised that there is no stash, so we can skip the check. */
1442         len = full_len;
1443         goto no_stash;
1444     }
1445
1446     if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
1447         /* accidental stringify on a GV? */
1448         name++;
1449     }
1450
1451     for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1452         if (name_cursor < name_em1 &&
1453             ((*name_cursor == ':'
1454              && name_cursor[1] == ':')
1455             || *name_cursor == '\''))
1456         {
1457             if (!stash)
1458                 stash = PL_defstash;
1459             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1460                 return NULL;
1461
1462             len = name_cursor - name;
1463             if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1464                 const char *key;
1465                 if (*name_cursor == ':') {
1466                     key = name;
1467                     len += 2;
1468                 } else {
1469                     char *tmpbuf;
1470                     Newx(tmpbuf, len+2, char);
1471                     Copy(name, tmpbuf, len, char);
1472                     tmpbuf[len++] = ':';
1473                     tmpbuf[len++] = ':';
1474                     key = tmpbuf;
1475                 }
1476                 gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add);
1477                 gv = gvp ? *gvp : NULL;
1478                 if (gv && gv != (const GV *)&PL_sv_undef) {
1479                     if (SvTYPE(gv) != SVt_PVGV)
1480                         gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8);
1481                     else
1482                         GvMULTI_on(gv);
1483                 }
1484                 if (key != name)
1485                     Safefree(key);
1486                 if (!gv || gv == (const GV *)&PL_sv_undef)
1487                     return NULL;
1488
1489                 if (!(stash = GvHV(gv)))
1490                 {
1491                     stash = GvHV(gv) = newHV();
1492                     if (!HvNAME_get(stash)) {
1493                         if (GvSTASH(gv) == PL_defstash && len == 6
1494                          && strnEQ(name, "CORE", 4))
1495                             hv_name_set(stash, "CORE", 4, 0);
1496                         else
1497                             hv_name_set(
1498                                 stash, nambeg, name_cursor-nambeg, is_utf8
1499                             );
1500                         /* If the containing stash has multiple effective
1501                            names, see that this one gets them, too. */
1502                         if (HvAUX(GvSTASH(gv))->xhv_name_count)
1503                             mro_package_moved(stash, NULL, gv, 1);
1504                     }
1505                 }
1506                 else if (!HvNAME_get(stash))
1507                     hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8);
1508             }
1509
1510             if (*name_cursor == ':')
1511                 name_cursor++;
1512             name = name_cursor+1;
1513             if (name == name_end)
1514                 return gv
1515                     ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1516         }
1517     }
1518     len = name_cursor - name;
1519
1520     /* No stash in name, so see how we can default */
1521
1522     if (!stash) {
1523     no_stash:
1524         if (len && isIDFIRST_lazy(name)) {
1525             bool global = FALSE;
1526
1527             switch (len) {
1528             case 1:
1529                 if (*name == '_')
1530                     global = TRUE;
1531                 break;
1532             case 3:
1533                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1534                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1535                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1536                     global = TRUE;
1537                 break;
1538             case 4:
1539                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1540                     && name[3] == 'V')
1541                     global = TRUE;
1542                 break;
1543             case 5:
1544                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1545                     && name[3] == 'I' && name[4] == 'N')
1546                     global = TRUE;
1547                 break;
1548             case 6:
1549                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1550                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1551                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1552                     global = TRUE;
1553                 break;
1554             case 7:
1555                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1556                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1557                     && name[6] == 'T')
1558                     global = TRUE;
1559                 break;
1560             }
1561
1562             if (global)
1563                 stash = PL_defstash;
1564             else if (IN_PERL_COMPILETIME) {
1565                 stash = PL_curstash;
1566                 if (add && (PL_hints & HINT_STRICT_VARS) &&
1567                     sv_type != SVt_PVCV &&
1568                     sv_type != SVt_PVGV &&
1569                     sv_type != SVt_PVFM &&
1570                     sv_type != SVt_PVIO &&
1571                     !(len == 1 && sv_type == SVt_PV &&
1572                       (*name == 'a' || *name == 'b')) )
1573                 {
1574                     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0);
1575                     if (!gvp ||
1576                         *gvp == (const GV *)&PL_sv_undef ||
1577                         SvTYPE(*gvp) != SVt_PVGV)
1578                     {
1579                         stash = NULL;
1580                     }
1581                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1582                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1583                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1584                     {
1585                         SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8);
1586                         /* diag_listed_as: Variable "%s" is not imported%s */
1587                         Perl_ck_warner_d(
1588                             aTHX_ packWARN(WARN_MISC),
1589                             "Variable \"%c%"SVf"\" is not imported",
1590                             sv_type == SVt_PVAV ? '@' :
1591                             sv_type == SVt_PVHV ? '%' : '$',
1592                             SVfARG(namesv));
1593                         if (GvCVu(*gvp))
1594                             Perl_ck_warner_d(
1595                                 aTHX_ packWARN(WARN_MISC),
1596                                 "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv)
1597                             );
1598                         stash = NULL;
1599                     }
1600                 }
1601             }
1602             else
1603                 stash = CopSTASH(PL_curcop);
1604         }
1605         else
1606             stash = PL_defstash;
1607     }
1608
1609     /* By this point we should have a stash and a name */
1610
1611     if (!stash) {
1612         if (add) {
1613             SV * const err = Perl_mess(aTHX_
1614                  "Global symbol \"%s%"SVf"\" requires explicit package name",
1615                  (sv_type == SVt_PV ? "$"
1616                   : sv_type == SVt_PVAV ? "@"
1617                   : sv_type == SVt_PVHV ? "%"
1618                   : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
1619             GV *gv;
1620             if (USE_UTF8_IN_NAMES)
1621                 SvUTF8_on(err);
1622             qerror(err);
1623             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1624             if(!gv) {
1625                 /* symbol table under destruction */
1626                 return NULL;
1627             }
1628             stash = GvHV(gv);
1629         }
1630         else
1631             return NULL;
1632     }
1633
1634     if (!SvREFCNT(stash))       /* symbol table under destruction */
1635         return NULL;
1636
1637     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
1638     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1639         if (addmg) gv = (GV *)newSV(0);
1640         else return NULL;
1641     }
1642     else gv = *gvp, addmg = 0;
1643     /* From this point on, addmg means gv has not been inserted in the
1644        symtab yet. */
1645
1646     if (SvTYPE(gv) == SVt_PVGV) {
1647         if (add) {
1648             GvMULTI_on(gv);
1649             gv_init_svtype(gv, sv_type);
1650             if (len == 1 && stash == PL_defstash) {
1651               if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
1652                 if (*name == '!')
1653                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1654                 else if (*name == '-' || *name == '+')
1655                     require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1656               }
1657               if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
1658                 switch (*name) {
1659                 case '[':
1660                     require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1661                     break;
1662                 case '`':
1663                     PL_sawampersand |= SAWAMPERSAND_LEFT;
1664                     (void)GvSVn(gv);
1665                     break;
1666                 case '&':
1667                     PL_sawampersand |= SAWAMPERSAND_MIDDLE;
1668                     (void)GvSVn(gv);
1669                     break;
1670                 case '\'':
1671                     PL_sawampersand |= SAWAMPERSAND_RIGHT;
1672                     (void)GvSVn(gv);
1673                     break;
1674                 }
1675               }
1676             }
1677             else if (len == 3 && sv_type == SVt_PVAV
1678                   && strnEQ(name, "ISA", 3)
1679                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1680                 gv_magicalize_isa(gv);
1681         }
1682         return gv;
1683     } else if (no_init) {
1684         assert(!addmg);
1685         return gv;
1686     } else if (no_expand && SvROK(gv)) {
1687         assert(!addmg);
1688         return gv;
1689     }
1690
1691     /* Adding a new symbol.
1692        Unless of course there was already something non-GV here, in which case
1693        we want to behave as if there was always a GV here, containing some sort
1694        of subroutine.
1695        Otherwise we run the risk of creating things like GvIO, which can cause
1696        subtle bugs. eg the one that tripped up SQL::Translator  */
1697
1698     faking_it = SvOK(gv);
1699
1700     if (add & GV_ADDWARN)
1701         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
1702                 SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
1703     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
1704
1705     if ( isIDFIRST_lazy_if(name, is_utf8)
1706                 && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
1707         GvMULTI_on(gv) ;
1708
1709     /* set up magic where warranted */
1710     if (stash != PL_defstash) { /* not the main stash */
1711         /* We only have to check for three names here: EXPORT, ISA
1712            and VERSION. All the others apply only to the main stash or to
1713            CORE (which is checked right after this). */
1714         if (len > 2) {
1715             const char * const name2 = name + 1;
1716             switch (*name) {
1717             case 'E':
1718                 if (strnEQ(name2, "XPORT", 5))
1719                     GvMULTI_on(gv);
1720                 break;
1721             case 'I':
1722                 if (strEQ(name2, "SA"))
1723                     gv_magicalize_isa(gv);
1724                 break;
1725             case 'V':
1726                 if (strEQ(name2, "ERSION"))
1727                     GvMULTI_on(gv);
1728                 break;
1729             default:
1730                 goto try_core;
1731             }
1732             goto add_magical_gv;
1733         }
1734       try_core:
1735         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1736           /* Avoid null warning: */
1737           const char * const stashname = HvNAME(stash); assert(stashname);
1738           if (strnEQ(stashname, "CORE", 4))
1739             S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1740         }
1741     }
1742     else if (len > 1) {
1743 #ifndef EBCDIC
1744         if (*name > 'V' ) {
1745             NOOP;
1746             /* Nothing else to do.
1747                The compiler will probably turn the switch statement into a
1748                branch table. Make sure we avoid even that small overhead for
1749                the common case of lower case variable names.  */
1750         } else
1751 #endif
1752         {
1753             const char * const name2 = name + 1;
1754             switch (*name) {
1755             case 'A':
1756                 if (strEQ(name2, "RGV")) {
1757                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1758                 }
1759                 else if (strEQ(name2, "RGVOUT")) {
1760                     GvMULTI_on(gv);
1761                 }
1762                 break;
1763             case 'E':
1764                 if (strnEQ(name2, "XPORT", 5))
1765                     GvMULTI_on(gv);
1766                 break;
1767             case 'I':
1768                 if (strEQ(name2, "SA")) {
1769                     gv_magicalize_isa(gv);
1770                 }
1771                 break;
1772             case 'S':
1773                 if (strEQ(name2, "IG")) {
1774                     HV *hv;
1775                     I32 i;
1776                     if (!PL_psig_name) {
1777                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1778                         Newxz(PL_psig_pend, SIG_SIZE, int);
1779                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1780                     } else {
1781                         /* I think that the only way to get here is to re-use an
1782                            embedded perl interpreter, where the previous
1783                            use didn't clean up fully because
1784                            PL_perl_destruct_level was 0. I'm not sure that we
1785                            "support" that, in that I suspect in that scenario
1786                            there are sufficient other garbage values left in the
1787                            interpreter structure that something else will crash
1788                            before we get here. I suspect that this is one of
1789                            those "doctor, it hurts when I do this" bugs.  */
1790                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1791                         Zero(PL_psig_pend, SIG_SIZE, int);
1792                     }
1793                     GvMULTI_on(gv);
1794                     hv = GvHVn(gv);
1795                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1796                     for (i = 1; i < SIG_SIZE; i++) {
1797                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1798                         if (init)
1799                             sv_setsv(*init, &PL_sv_undef);
1800                     }
1801                 }
1802                 break;
1803             case 'V':
1804                 if (strEQ(name2, "ERSION"))
1805                     GvMULTI_on(gv);
1806                 break;
1807             case '\003':        /* $^CHILD_ERROR_NATIVE */
1808                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1809                     goto magicalize;
1810                 break;
1811             case '\005':        /* $^ENCODING */
1812                 if (strEQ(name2, "NCODING"))
1813                     goto magicalize;
1814                 break;
1815             case '\007':        /* $^GLOBAL_PHASE */
1816                 if (strEQ(name2, "LOBAL_PHASE"))
1817                     goto ro_magicalize;
1818                 break;
1819             case '\015':        /* $^MATCH */
1820                 if (strEQ(name2, "ATCH"))
1821                     goto magicalize;
1822             case '\017':        /* $^OPEN */
1823                 if (strEQ(name2, "PEN"))
1824                     goto magicalize;
1825                 break;
1826             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1827                 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1828                     goto magicalize;
1829                 break;
1830             case '\024':        /* ${^TAINT} */
1831                 if (strEQ(name2, "AINT"))
1832                     goto ro_magicalize;
1833                 break;
1834             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1835                 if (strEQ(name2, "NICODE"))
1836                     goto ro_magicalize;
1837                 if (strEQ(name2, "TF8LOCALE"))
1838                     goto ro_magicalize;
1839                 if (strEQ(name2, "TF8CACHE"))
1840                     goto magicalize;
1841                 break;
1842             case '\027':        /* $^WARNING_BITS */
1843                 if (strEQ(name2, "ARNING_BITS"))
1844                     goto magicalize;
1845                 break;
1846             case '1':
1847             case '2':
1848             case '3':
1849             case '4':
1850             case '5':
1851             case '6':
1852             case '7':
1853             case '8':
1854             case '9':
1855             {
1856                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1857                    this test  */
1858                 /* This snippet is taken from is_gv_magical */
1859                 const char *end = name + len;
1860                 while (--end > name) {
1861                     if (!isDIGIT(*end)) goto add_magical_gv;
1862                 }
1863                 goto magicalize;
1864             }
1865             }
1866         }
1867     } else {
1868         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1869            be case '\0' in this switch statement (ie a default case)  */
1870         switch (*name) {
1871         case '&':               /* $& */
1872         case '`':               /* $` */
1873         case '\'':              /* $' */
1874             if (!(
1875                 sv_type == SVt_PVAV ||
1876                 sv_type == SVt_PVHV ||
1877                 sv_type == SVt_PVCV ||
1878                 sv_type == SVt_PVFM ||
1879                 sv_type == SVt_PVIO
1880                 )) { PL_sawampersand |=
1881                         (*name == '`')
1882                             ? SAWAMPERSAND_LEFT
1883                             : (*name == '&')
1884                                 ? SAWAMPERSAND_MIDDLE
1885                                 : SAWAMPERSAND_RIGHT;
1886                 }
1887             goto magicalize;
1888
1889         case ':':               /* $: */
1890             sv_setpv(GvSVn(gv),PL_chopset);
1891             goto magicalize;
1892
1893         case '?':               /* $? */
1894 #ifdef COMPLEX_STATUS
1895             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1896 #endif
1897             goto magicalize;
1898
1899         case '!':               /* $! */
1900             GvMULTI_on(gv);
1901             /* If %! has been used, automatically load Errno.pm. */
1902
1903             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1904
1905             /* magicalization must be done before require_tie_mod is called */
1906             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1907             {
1908                 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1909                 addmg = 0;
1910                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1911             }
1912
1913             break;
1914         case '-':               /* $- */
1915         case '+':               /* $+ */
1916         GvMULTI_on(gv); /* no used once warnings here */
1917         {
1918             AV* const av = GvAVn(gv);
1919             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1920
1921             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1922             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1923             if (avc)
1924                 SvREADONLY_on(GvSVn(gv));
1925             SvREADONLY_on(av);
1926
1927             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1928             {
1929                 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1930                 addmg = 0;
1931                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1932             }
1933
1934             break;
1935         }
1936         case '*':               /* $* */
1937         case '#':               /* $# */
1938             if (sv_type == SVt_PV)
1939                 /* diag_listed_as: $* is no longer supported */
1940                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1941                                  "$%c is no longer supported", *name);
1942             break;
1943         case '|':               /* $| */
1944             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1945             goto magicalize;
1946
1947         case '\010':    /* $^H */
1948             {
1949                 HV *const hv = GvHVn(gv);
1950                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1951             }
1952             goto magicalize;
1953         case '[':               /* $[ */
1954             if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
1955              && FEATURE_ARYBASE_IS_ENABLED) {
1956                 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1957                 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1958                 addmg = 0;
1959             }
1960             else goto magicalize;
1961             break;
1962         case '\023':    /* $^S */
1963         ro_magicalize:
1964             SvREADONLY_on(GvSVn(gv));
1965             /* FALL THROUGH */
1966         case '0':               /* $0 */
1967         case '1':               /* $1 */
1968         case '2':               /* $2 */
1969         case '3':               /* $3 */
1970         case '4':               /* $4 */
1971         case '5':               /* $5 */
1972         case '6':               /* $6 */
1973         case '7':               /* $7 */
1974         case '8':               /* $8 */
1975         case '9':               /* $9 */
1976         case '^':               /* $^ */
1977         case '~':               /* $~ */
1978         case '=':               /* $= */
1979         case '%':               /* $% */
1980         case '.':               /* $. */
1981         case '(':               /* $( */
1982         case ')':               /* $) */
1983         case '<':               /* $< */
1984         case '>':               /* $> */
1985         case '\\':              /* $\ */
1986         case '/':               /* $/ */
1987         case '$':               /* $$ */
1988         case '\001':    /* $^A */
1989         case '\003':    /* $^C */
1990         case '\004':    /* $^D */
1991         case '\005':    /* $^E */
1992         case '\006':    /* $^F */
1993         case '\011':    /* $^I, NOT \t in EBCDIC */
1994         case '\016':    /* $^N */
1995         case '\017':    /* $^O */
1996         case '\020':    /* $^P */
1997         case '\024':    /* $^T */
1998         case '\027':    /* $^W */
1999         magicalize:
2000             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2001             break;
2002
2003         case '\014':    /* $^L */
2004             sv_setpvs(GvSVn(gv),"\f");
2005             PL_formfeed = GvSV(gv);
2006             break;
2007         case ';':               /* $; */
2008             sv_setpvs(GvSVn(gv),"\034");
2009             break;
2010         case ']':               /* $] */
2011         {
2012             SV * const sv = GvSV(gv);
2013             if (!sv_derived_from(PL_patchlevel, "version"))
2014                 upg_version(PL_patchlevel, TRUE);
2015             GvSV(gv) = vnumify(PL_patchlevel);
2016             SvREADONLY_on(GvSV(gv));
2017             SvREFCNT_dec(sv);
2018         }
2019         break;
2020         case '\026':    /* $^V */
2021         {
2022             SV * const sv = GvSV(gv);
2023             GvSV(gv) = new_version(PL_patchlevel);
2024             SvREADONLY_on(GvSV(gv));
2025             SvREFCNT_dec(sv);
2026         }
2027         break;
2028         }
2029     }
2030   add_magical_gv:
2031     if (addmg) {
2032         if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
2033              GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
2034            ))
2035             (void)hv_store(stash,name,len,(SV *)gv,0);
2036         else SvREFCNT_dec(gv), gv = NULL;
2037     }
2038     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2039     return gv;
2040 }
2041
2042 void
2043 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2044 {
2045     const char *name;
2046     const HV * const hv = GvSTASH(gv);
2047
2048     PERL_ARGS_ASSERT_GV_FULLNAME4;
2049
2050     sv_setpv(sv, prefix ? prefix : "");
2051
2052     if (hv && (name = HvNAME(hv))) {
2053       const STRLEN len = HvNAMELEN(hv);
2054       if (keepmain || strnNE(name, "main", len)) {
2055         sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2056         sv_catpvs(sv,"::");
2057       }
2058     }
2059     else sv_catpvs(sv,"__ANON__::");
2060     sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2061 }
2062
2063 void
2064 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2065 {
2066     const GV * const egv = GvEGVx(gv);
2067
2068     PERL_ARGS_ASSERT_GV_EFULLNAME4;
2069
2070     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2071 }
2072
2073 void
2074 Perl_gv_check(pTHX_ const HV *stash)
2075 {
2076     dVAR;
2077     I32 i;
2078
2079     PERL_ARGS_ASSERT_GV_CHECK;
2080
2081     if (!HvARRAY(stash))
2082         return;
2083     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2084         const HE *entry;
2085         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2086             GV *gv;
2087             HV *hv;
2088             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2089                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2090             {
2091                 if (hv != PL_defstash && hv != stash)
2092                      gv_check(hv);              /* nested package */
2093             }
2094             else if ( *HeKEY(entry) != '_'
2095                         && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2096                 const char *file;
2097                 gv = MUTABLE_GV(HeVAL(entry));
2098                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2099                     continue;
2100                 file = GvFILE(gv);
2101                 CopLINE_set(PL_curcop, GvLINE(gv));
2102 #ifdef USE_ITHREADS
2103                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
2104 #else
2105                 CopFILEGV(PL_curcop)
2106                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2107 #endif
2108                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2109                         "Name \"%"HEKf"::%"HEKf
2110                         "\" used only once: possible typo",
2111                             HEKfARG(HvNAME_HEK(stash)),
2112                             HEKfARG(GvNAME_HEK(gv)));
2113             }
2114         }
2115     }
2116 }
2117
2118 GV *
2119 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2120 {
2121     dVAR;
2122     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2123
2124     return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
2125                                     SVfARG(newSVpvn_flags(pack, strlen(pack),
2126                                             SVs_TEMP | flags)),
2127                                 (long)PL_gensym++),
2128                       GV_ADD, SVt_PVGV);
2129 }
2130
2131 /* hopefully this is only called on local symbol table entries */
2132
2133 GP*
2134 Perl_gp_ref(pTHX_ GP *gp)
2135 {
2136     dVAR;
2137     if (!gp)
2138         return NULL;
2139     gp->gp_refcnt++;
2140     if (gp->gp_cv) {
2141         if (gp->gp_cvgen) {
2142             /* If the GP they asked for a reference to contains
2143                a method cache entry, clear it first, so that we
2144                don't infect them with our cached entry */
2145             SvREFCNT_dec(gp->gp_cv);
2146             gp->gp_cv = NULL;
2147             gp->gp_cvgen = 0;
2148         }
2149     }
2150     return gp;
2151 }
2152
2153 void
2154 Perl_gp_free(pTHX_ GV *gv)
2155 {
2156     dVAR;
2157     GP* gp;
2158     int attempts = 100;
2159
2160     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2161         return;
2162     if (gp->gp_refcnt == 0) {
2163         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2164                          "Attempt to free unreferenced glob pointers"
2165                          pTHX__FORMAT pTHX__VALUE);
2166         return;
2167     }
2168     if (--gp->gp_refcnt > 0) {
2169         if (gp->gp_egv == gv)
2170             gp->gp_egv = 0;
2171         GvGP_set(gv, NULL);
2172         return;
2173     }
2174
2175     while (1) {
2176       /* Copy and null out all the glob slots, so destructors do not see
2177          freed SVs. */
2178       HEK * const file_hek = gp->gp_file_hek;
2179       SV  * const sv       = gp->gp_sv;
2180       AV  * const av       = gp->gp_av;
2181       HV  * const hv       = gp->gp_hv;
2182       IO  * const io       = gp->gp_io;
2183       CV  * const cv       = gp->gp_cv;
2184       CV  * const form     = gp->gp_form;
2185
2186       gp->gp_file_hek = NULL;
2187       gp->gp_sv       = NULL;
2188       gp->gp_av       = NULL;
2189       gp->gp_hv       = NULL;
2190       gp->gp_io       = NULL;
2191       gp->gp_cv       = NULL;
2192       gp->gp_form     = NULL;
2193
2194       if (file_hek)
2195         unshare_hek(file_hek);
2196
2197       SvREFCNT_dec(sv);
2198       SvREFCNT_dec(av);
2199       /* FIXME - another reference loop GV -> symtab -> GV ?
2200          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2201       if (hv && SvTYPE(hv) == SVt_PVHV) {
2202         const HEK *hvname_hek = HvNAME_HEK(hv);
2203         if (PL_stashcache && hvname_hek)
2204            (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2205                       (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2206                       G_DISCARD);
2207         SvREFCNT_dec(hv);
2208       }
2209       SvREFCNT_dec(io);
2210       SvREFCNT_dec(cv);
2211       SvREFCNT_dec(form);
2212
2213       if (!gp->gp_file_hek
2214        && !gp->gp_sv
2215        && !gp->gp_av
2216        && !gp->gp_hv
2217        && !gp->gp_io
2218        && !gp->gp_cv
2219        && !gp->gp_form) break;
2220
2221       if (--attempts == 0) {
2222         Perl_die(aTHX_
2223           "panic: gp_free failed to free glob pointer - "
2224           "something is repeatedly re-creating entries"
2225         );
2226       }
2227     }
2228
2229     Safefree(gp);
2230     GvGP_set(gv, NULL);
2231 }
2232
2233 int
2234 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2235 {
2236     AMT * const amtp = (AMT*)mg->mg_ptr;
2237     PERL_UNUSED_ARG(sv);
2238
2239     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2240
2241     if (amtp && AMT_AMAGIC(amtp)) {
2242         int i;
2243         for (i = 1; i < NofAMmeth; i++) {
2244             CV * const cv = amtp->table[i];
2245             if (cv) {
2246                 SvREFCNT_dec(MUTABLE_SV(cv));
2247                 amtp->table[i] = NULL;
2248             }
2249         }
2250     }
2251  return 0;
2252 }
2253
2254 /* Updates and caches the CV's */
2255 /* Returns:
2256  * 1 on success and there is some overload
2257  * 0 if there is no overload
2258  * -1 if some error occurred and it couldn't croak
2259  */
2260
2261 int
2262 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2263 {
2264   dVAR;
2265   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2266   AMT amt;
2267   const struct mro_meta* stash_meta = HvMROMETA(stash);
2268   U32 newgen;
2269
2270   PERL_ARGS_ASSERT_GV_AMUPDATE;
2271
2272   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2273   if (mg) {
2274       const AMT * const amtp = (AMT*)mg->mg_ptr;
2275       if (amtp->was_ok_sub == newgen) {
2276           return AMT_OVERLOADED(amtp) ? 1 : 0;
2277       }
2278       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2279   }
2280
2281   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2282
2283   Zero(&amt,1,AMT);
2284   amt.was_ok_sub = newgen;
2285   amt.fallback = AMGfallNO;
2286   amt.flags = 0;
2287
2288   {
2289     int filled = 0, have_ovl = 0;
2290     int i, lim = 1;
2291
2292     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2293
2294     /* Try to find via inheritance. */
2295     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2296     SV * const sv = gv ? GvSV(gv) : NULL;
2297     CV* cv;
2298
2299     if (!gv)
2300     {
2301       if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2302         lim = DESTROY_amg;              /* Skip overloading entries. */
2303     }
2304 #ifdef PERL_DONT_CREATE_GVSV
2305     else if (!sv) {
2306         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2307     }
2308 #endif
2309     else if (SvTRUE(sv))
2310         /* don't need to set overloading here because fallback => 1
2311          * is the default setting for classes without overloading */
2312         amt.fallback=AMGfallYES;
2313     else if (SvOK(sv)) {
2314         amt.fallback=AMGfallNEVER;
2315         filled = 1;
2316         have_ovl = 1;
2317     }
2318     else {
2319         filled = 1;
2320         have_ovl = 1;
2321     }
2322
2323     for (i = 1; i < lim; i++)
2324         amt.table[i] = NULL;
2325     for (; i < NofAMmeth; i++) {
2326         const char * const cooky = PL_AMG_names[i];
2327         /* Human-readable form, for debugging: */
2328         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2329         const STRLEN l = PL_AMG_namelens[i];
2330
2331         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2332                      cp, HvNAME_get(stash)) );
2333         /* don't fill the cache while looking up!
2334            Creation of inheritance stubs in intermediate packages may
2335            conflict with the logic of runtime method substitution.
2336            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2337            then we could have created stubs for "(+0" in A and C too.
2338            But if B overloads "bool", we may want to use it for
2339            numifying instead of C's "+0". */
2340         if (i >= DESTROY_amg)
2341             gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
2342         else                            /* Autoload taken care of below */
2343             gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2344         cv = 0;
2345         if (gv && (cv = GvCV(gv))) {
2346             if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2347               const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2348               if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2349                && strEQ(hvname, "overload")) {
2350                 /* This is a hack to support autoloading..., while
2351                    knowing *which* methods were declared as overloaded. */
2352                 /* GvSV contains the name of the method. */
2353                 GV *ngv = NULL;
2354                 SV *gvsv = GvSV(gv);
2355
2356                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2357                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2358                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2359                 if (!gvsv || !SvPOK(gvsv)
2360                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2361                 {
2362                     /* Can be an import stub (created by "can"). */
2363                     if (destructing) {
2364                         return -1;
2365                     }
2366                     else {
2367                         const SV * const name = (gvsv && SvPOK(gvsv))
2368                                                     ? gvsv
2369                                                     : newSVpvs_flags("???", SVs_TEMP);
2370                         /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2371                         Perl_croak(aTHX_ "%s method \"%"SVf256
2372                                     "\" overloading \"%s\" "\
2373                                     "in package \"%"HEKf256"\"",
2374                                    (GvCVGEN(gv) ? "Stub found while resolving"
2375                                     : "Can't resolve"),
2376                                    SVfARG(name), cp,
2377                                    HEKfARG(
2378                                         HvNAME_HEK(stash)
2379                                    ));
2380                     }
2381                 }
2382                 cv = GvCV(gv = ngv);
2383               }
2384             }
2385             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2386                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2387                          GvNAME(CvGV(cv))) );
2388             filled = 1;
2389             if (i < DESTROY_amg)
2390                 have_ovl = 1;
2391         } else if (gv) {                /* Autoloaded... */
2392             cv = MUTABLE_CV(gv);
2393             filled = 1;
2394         }
2395         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2396     }
2397     if (filled) {
2398       AMT_AMAGIC_on(&amt);
2399       if (have_ovl)
2400           AMT_OVERLOADED_on(&amt);
2401       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2402                                                 (char*)&amt, sizeof(AMT));
2403       return have_ovl;
2404     }
2405   }
2406   /* Here we have no table: */
2407   /* no_table: */
2408   AMT_AMAGIC_off(&amt);
2409   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2410                                                 (char*)&amt, sizeof(AMTS));
2411   return 0;
2412 }
2413
2414
2415 CV*
2416 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2417 {
2418     dVAR;
2419     MAGIC *mg;
2420     AMT *amtp;
2421     U32 newgen;
2422     struct mro_meta* stash_meta;
2423
2424     if (!stash || !HvNAME_get(stash))
2425         return NULL;
2426
2427     stash_meta = HvMROMETA(stash);
2428     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2429
2430     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2431     if (!mg) {
2432       do_update:
2433         /* If we're looking up a destructor to invoke, we must avoid
2434          * that Gv_AMupdate croaks, because we might be dying already */
2435         if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2436             /* and if it didn't found a destructor, we fall back
2437              * to a simpler method that will only look for the
2438              * destructor instead of the whole magic */
2439             if (id == DESTROY_amg) {
2440                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2441                 if (gv)
2442                     return GvCV(gv);
2443             }
2444             return NULL;
2445         }
2446         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2447     }
2448     assert(mg);
2449     amtp = (AMT*)mg->mg_ptr;
2450     if ( amtp->was_ok_sub != newgen )
2451         goto do_update;
2452     if (AMT_AMAGIC(amtp)) {
2453         CV * const ret = amtp->table[id];
2454         if (ret && isGV(ret)) {         /* Autoloading stab */
2455             /* Passing it through may have resulted in a warning
2456                "Inherited AUTOLOAD for a non-method deprecated", since
2457                our caller is going through a function call, not a method call.
2458                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2459             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2460
2461             if (gv && GvCV(gv))
2462                 return GvCV(gv);
2463         }
2464         return ret;
2465     }
2466
2467     return NULL;
2468 }
2469
2470
2471 /* Implement tryAMAGICun_MG macro.
2472    Do get magic, then see if the stack arg is overloaded and if so call it.
2473    Flags:
2474         AMGf_set     return the arg using SETs rather than assigning to
2475                      the targ
2476         AMGf_numeric apply sv_2num to the stack arg.
2477 */
2478
2479 bool
2480 Perl_try_amagic_un(pTHX_ int method, int flags) {
2481     dVAR;
2482     dSP;
2483     SV* tmpsv;
2484     SV* const arg = TOPs;
2485
2486     SvGETMAGIC(arg);
2487
2488     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2489                                               AMGf_noright | AMGf_unary))) {
2490         if (flags & AMGf_set) {
2491             SETs(tmpsv);
2492         }
2493         else {
2494             dTARGET;
2495             if (SvPADMY(TARG)) {
2496                 sv_setsv(TARG, tmpsv);
2497                 SETTARG;
2498             }
2499             else
2500                 SETs(tmpsv);
2501         }
2502         PUTBACK;
2503         return TRUE;
2504     }
2505
2506     if ((flags & AMGf_numeric) && SvROK(arg))
2507         *sp = sv_2num(arg);
2508     return FALSE;
2509 }
2510
2511
2512 /* Implement tryAMAGICbin_MG macro.
2513    Do get magic, then see if the two stack args are overloaded and if so
2514    call it.
2515    Flags:
2516         AMGf_set     return the arg using SETs rather than assigning to
2517                      the targ
2518         AMGf_assign  op may be called as mutator (eg +=)
2519         AMGf_numeric apply sv_2num to the stack arg.
2520 */
2521
2522 bool
2523 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2524     dVAR;
2525     dSP;
2526     SV* const left = TOPm1s;
2527     SV* const right = TOPs;
2528
2529     SvGETMAGIC(left);
2530     if (left != right)
2531         SvGETMAGIC(right);
2532
2533     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2534         SV * const tmpsv = amagic_call(left, right, method,
2535                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2536         if (tmpsv) {
2537             if (flags & AMGf_set) {
2538                 (void)POPs;
2539                 SETs(tmpsv);
2540             }
2541             else {
2542                 dATARGET;
2543                 (void)POPs;
2544                 if (opASSIGN || SvPADMY(TARG)) {
2545                     sv_setsv(TARG, tmpsv);
2546                     SETTARG;
2547                 }
2548                 else
2549                     SETs(tmpsv);
2550             }
2551             PUTBACK;
2552             return TRUE;
2553         }
2554     }
2555     if(left==right && SvGMAGICAL(left)) {
2556         SV * const left = sv_newmortal();
2557         *(sp-1) = left;
2558         /* Print the uninitialized warning now, so it includes the vari-
2559            able name. */
2560         if (!SvOK(right)) {
2561             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2562             sv_setsv_flags(left, &PL_sv_no, 0);
2563         }
2564         else sv_setsv_flags(left, right, 0);
2565         SvGETMAGIC(right);
2566     }
2567     if (flags & AMGf_numeric) {
2568         if (SvROK(TOPm1s))
2569             *(sp-1) = sv_2num(TOPm1s);
2570         if (SvROK(right))
2571             *sp     = sv_2num(right);
2572     }
2573     return FALSE;
2574 }
2575
2576 SV *
2577 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2578     SV *tmpsv = NULL;
2579
2580     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2581
2582     while (SvAMAGIC(ref) &&
2583            (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2584                                 AMGf_noright | AMGf_unary))) {
2585         if (!SvROK(tmpsv))
2586             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2587         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2588             /* Bail out if it returns us the same reference.  */
2589             return tmpsv;
2590         }
2591         ref = tmpsv;
2592     }
2593     return tmpsv ? tmpsv : ref;
2594 }
2595
2596 bool
2597 Perl_amagic_is_enabled(pTHX_ int method)
2598 {
2599       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2600
2601       assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2602
2603       if ( !lex_mask || !SvOK(lex_mask) )
2604           /* overloading lexically disabled */
2605           return FALSE;
2606       else if ( lex_mask && SvPOK(lex_mask) ) {
2607           /* we have an entry in the hints hash, check if method has been
2608            * masked by overloading.pm */
2609           STRLEN len;
2610           const int offset = method / 8;
2611           const int bit    = method % 8;
2612           char *pv = SvPV(lex_mask, len);
2613
2614           /* Bit set, so this overloading operator is disabled */
2615           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2616               return FALSE;
2617       }
2618       return TRUE;
2619 }
2620
2621 SV*
2622 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2623 {
2624   dVAR;
2625   MAGIC *mg;
2626   CV *cv=NULL;
2627   CV **cvp=NULL, **ocvp=NULL;
2628   AMT *amtp=NULL, *oamtp=NULL;
2629   int off = 0, off1, lr = 0, notfound = 0;
2630   int postpr = 0, force_cpy = 0;
2631   int assign = AMGf_assign & flags;
2632   const int assignshift = assign ? 1 : 0;
2633   int use_default_op = 0;
2634   int force_scalar = 0;
2635 #ifdef DEBUGGING
2636   int fl=0;
2637 #endif
2638   HV* stash=NULL;
2639
2640   PERL_ARGS_ASSERT_AMAGIC_CALL;
2641
2642   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2643       if (!amagic_is_enabled(method)) return NULL;
2644   }
2645
2646   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2647       && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
2648       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2649       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2650                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2651                         : NULL))
2652       && ((cv = cvp[off=method+assignshift])
2653           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2654                                                           * usual method */
2655                   (
2656 #ifdef DEBUGGING
2657                    fl = 1,
2658 #endif
2659                    cv = cvp[off=method])))) {
2660     lr = -1;                    /* Call method for left argument */
2661   } else {
2662     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2663       int logic;
2664
2665       /* look for substituted methods */
2666       /* In all the covered cases we should be called with assign==0. */
2667          switch (method) {
2668          case inc_amg:
2669            force_cpy = 1;
2670            if ((cv = cvp[off=add_ass_amg])
2671                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2672              right = &PL_sv_yes; lr = -1; assign = 1;
2673            }
2674            break;
2675          case dec_amg:
2676            force_cpy = 1;
2677            if ((cv = cvp[off = subtr_ass_amg])
2678                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2679              right = &PL_sv_yes; lr = -1; assign = 1;
2680            }
2681            break;
2682          case bool__amg:
2683            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2684            break;
2685          case numer_amg:
2686            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2687            break;
2688          case string_amg:
2689            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2690            break;
2691          case not_amg:
2692            (void)((cv = cvp[off=bool__amg])
2693                   || (cv = cvp[off=numer_amg])
2694                   || (cv = cvp[off=string_amg]));
2695            if (cv)
2696                postpr = 1;
2697            break;
2698          case copy_amg:
2699            {
2700              /*
2701                   * SV* ref causes confusion with the interpreter variable of
2702                   * the same name
2703                   */
2704              SV* const tmpRef=SvRV(left);
2705              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2706                 /*
2707                  * Just to be extra cautious.  Maybe in some
2708                  * additional cases sv_setsv is safe, too.
2709                  */
2710                 SV* const newref = newSVsv(tmpRef);
2711                 SvOBJECT_on(newref);
2712                 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2713                    delegate to the stash. */
2714                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2715                 return newref;
2716              }
2717            }
2718            break;
2719          case abs_amg:
2720            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2721                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2722              SV* const nullsv=sv_2mortal(newSViv(0));
2723              if (off1==lt_amg) {
2724                SV* const lessp = amagic_call(left,nullsv,
2725                                        lt_amg,AMGf_noright);
2726                logic = SvTRUE(lessp);
2727              } else {
2728                SV* const lessp = amagic_call(left,nullsv,
2729                                        ncmp_amg,AMGf_noright);
2730                logic = (SvNV(lessp) < 0);
2731              }
2732              if (logic) {
2733                if (off==subtr_amg) {
2734                  right = left;
2735                  left = nullsv;
2736                  lr = 1;
2737                }
2738              } else {
2739                return left;
2740              }
2741            }
2742            break;
2743          case neg_amg:
2744            if ((cv = cvp[off=subtr_amg])) {
2745              right = left;
2746              left = sv_2mortal(newSViv(0));
2747              lr = 1;
2748            }
2749            break;
2750          case int_amg:
2751          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2752          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2753          case regexp_amg:
2754              /* FAIL safe */
2755              return NULL;       /* Delegate operation to standard mechanisms. */
2756              break;
2757          case to_sv_amg:
2758          case to_av_amg:
2759          case to_hv_amg:
2760          case to_gv_amg:
2761          case to_cv_amg:
2762              /* FAIL safe */
2763              return left;       /* Delegate operation to standard mechanisms. */
2764              break;
2765          default:
2766            goto not_found;
2767          }
2768          if (!cv) goto not_found;
2769     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2770                && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
2771                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2772                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2773                           ? (amtp = (AMT*)mg->mg_ptr)->table
2774                           : NULL))
2775                && ((cv = cvp[off=method+assignshift])
2776                    || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2777                                                                    * usual method */
2778                        (
2779 #ifdef DEBUGGING
2780                         fl = 1,
2781 #endif
2782                         cv = cvp[off=method])))) { /* Method for right
2783                                                     * argument found */
2784         lr=1;
2785     } else if (((cvp && amtp->fallback > AMGfallNEVER)
2786                 || (ocvp && oamtp->fallback > AMGfallNEVER))
2787                && !(flags & AMGf_unary)) {
2788                                 /* We look for substitution for
2789                                  * comparison operations and
2790                                  * concatenation */
2791       if (method==concat_amg || method==concat_ass_amg
2792           || method==repeat_amg || method==repeat_ass_amg) {
2793         return NULL;            /* Delegate operation to string conversion */
2794       }
2795       off = -1;
2796       switch (method) {
2797          case lt_amg:
2798          case le_amg:
2799          case gt_amg:
2800          case ge_amg:
2801          case eq_amg:
2802          case ne_amg:
2803              off = ncmp_amg;
2804              break;
2805          case slt_amg:
2806          case sle_amg:
2807          case sgt_amg:
2808          case sge_amg:
2809          case seq_amg:
2810          case sne_amg:
2811              off = scmp_amg;
2812              break;
2813          }
2814       if (off != -1) {
2815           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2816               cv = ocvp[off];
2817               lr = -1;
2818           }
2819           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2820               cv = cvp[off];
2821               lr = 1;
2822           }
2823       }
2824       if (cv)
2825           postpr = 1;
2826       else
2827           goto not_found;
2828     } else {
2829     not_found:                  /* No method found, either report or croak */
2830       switch (method) {
2831          case to_sv_amg:
2832          case to_av_amg:
2833          case to_hv_amg:
2834          case to_gv_amg:
2835          case to_cv_amg:
2836              /* FAIL safe */
2837              return left;       /* Delegate operation to standard mechanisms. */
2838              break;
2839       }
2840       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2841         notfound = 1; lr = -1;
2842       } else if (cvp && (cv=cvp[nomethod_amg])) {
2843         notfound = 1; lr = 1;
2844       } else if ((use_default_op =
2845                   (!ocvp || oamtp->fallback >= AMGfallYES)
2846                   && (!cvp || amtp->fallback >= AMGfallYES))
2847                  && !DEBUG_o_TEST) {
2848         /* Skip generating the "no method found" message.  */
2849         return NULL;
2850       } else {
2851         SV *msg;
2852         if (off==-1) off=method;
2853         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2854                       "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2855                       AMG_id2name(method + assignshift),
2856                       (flags & AMGf_unary ? " " : "\n\tleft "),
2857                       SvAMAGIC(left)?
2858                         "in overloaded package ":
2859                         "has no overloaded magic",
2860                       SvAMAGIC(left)?
2861                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2862                         SVfARG(&PL_sv_no),
2863                       SvAMAGIC(right)?
2864                         ",\n\tright argument in overloaded package ":
2865                         (flags & AMGf_unary
2866                          ? ""
2867                          : ",\n\tright argument has no overloaded magic"),
2868                       SvAMAGIC(right)?
2869                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2870                         SVfARG(&PL_sv_no)));
2871         if (use_default_op) {
2872           DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
2873         } else {
2874           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2875         }
2876         return NULL;
2877       }
2878       force_cpy = force_cpy || assign;
2879     }
2880   }
2881
2882   switch (method) {
2883     /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
2884      * operation. we need this to return a value, so that it can be assigned
2885      * later on, in the postpr block (case inc_amg/dec_amg), even if the
2886      * increment or decrement was itself called in void context */
2887     case inc_amg:
2888       if (off == add_amg)
2889         force_scalar = 1;
2890       break;
2891     case dec_amg:
2892       if (off == subtr_amg)
2893         force_scalar = 1;
2894       break;
2895     /* in these cases, we're calling an assignment variant of an operator
2896      * (+= rather than +, for instance). regardless of whether it's a
2897      * fallback or not, it always has to return a value, which will be
2898      * assigned to the proper variable later */
2899     case add_amg:
2900     case subtr_amg:
2901     case mult_amg:
2902     case div_amg:
2903     case modulo_amg:
2904     case pow_amg:
2905     case lshift_amg:
2906     case rshift_amg:
2907     case repeat_amg:
2908     case concat_amg:
2909     case band_amg:
2910     case bor_amg:
2911     case bxor_amg:
2912       if (assign)
2913         force_scalar = 1;
2914       break;
2915     /* the copy constructor always needs to return a value */
2916     case copy_amg:
2917       force_scalar = 1;
2918       break;
2919     /* because of the way these are implemented (they don't perform the
2920      * dereferencing themselves, they return a reference that perl then
2921      * dereferences later), they always have to be in scalar context */
2922     case to_sv_amg:
2923     case to_av_amg:
2924     case to_hv_amg:
2925     case to_gv_amg:
2926     case to_cv_amg:
2927       force_scalar = 1;
2928       break;
2929     /* these don't have an op of their own; they're triggered by their parent
2930      * op, so the context there isn't meaningful ('$a and foo()' in void
2931      * context still needs to pass scalar context on to $a's bool overload) */
2932     case bool__amg:
2933     case numer_amg:
2934     case string_amg:
2935       force_scalar = 1;
2936       break;
2937   }
2938
2939 #ifdef DEBUGGING
2940   if (!notfound) {
2941     DEBUG_o(Perl_deb(aTHX_
2942                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
2943                      AMG_id2name(off),
2944                      method+assignshift==off? "" :
2945                      " (initially \"",
2946                      method+assignshift==off? "" :
2947                      AMG_id2name(method+assignshift),
2948                      method+assignshift==off? "" : "\")",
2949                      flags & AMGf_unary? "" :
2950                      lr==1 ? " for right argument": " for left argument",
2951                      flags & AMGf_unary? " for argument" : "",
2952                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
2953                      fl? ",\n\tassignment variant used": "") );
2954   }
2955 #endif
2956     /* Since we use shallow copy during assignment, we need
2957      * to dublicate the contents, probably calling user-supplied
2958      * version of copy operator
2959      */
2960     /* We need to copy in following cases:
2961      * a) Assignment form was called.
2962      *          assignshift==1,  assign==T, method + 1 == off
2963      * b) Increment or decrement, called directly.
2964      *          assignshift==0,  assign==0, method + 0 == off
2965      * c) Increment or decrement, translated to assignment add/subtr.
2966      *          assignshift==0,  assign==T,
2967      *          force_cpy == T
2968      * d) Increment or decrement, translated to nomethod.
2969      *          assignshift==0,  assign==0,
2970      *          force_cpy == T
2971      * e) Assignment form translated to nomethod.
2972      *          assignshift==1,  assign==T, method + 1 != off
2973      *          force_cpy == T
2974      */
2975     /*  off is method, method+assignshift, or a result of opcode substitution.
2976      *  In the latter case assignshift==0, so only notfound case is important.
2977      */
2978   if ( (lr == -1) && ( ( (method + assignshift == off)
2979         && (assign || (method == inc_amg) || (method == dec_amg)))
2980       || force_cpy) )
2981   {
2982       /* newSVsv does not behave as advertised, so we copy missing
2983        * information by hand */
2984       SV *tmpRef = SvRV(left);
2985       SV *rv_copy;
2986       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2987           SvRV_set(left, rv_copy);
2988           SvSETMAGIC(left);
2989           SvREFCNT_dec(tmpRef);
2990       }
2991   }
2992
2993   {
2994     dSP;
2995     BINOP myop;
2996     SV* res;
2997     const bool oldcatch = CATCH_GET;
2998     I32 oldmark, nret;
2999     int gimme = force_scalar ? G_SCALAR : GIMME_V;
3000
3001     CATCH_SET(TRUE);
3002     Zero(&myop, 1, BINOP);
3003     myop.op_last = (OP *) &myop;
3004     myop.op_next = NULL;
3005     myop.op_flags = OPf_STACKED;
3006
3007     switch (gimme) {
3008         case G_VOID:
3009             myop.op_flags |= OPf_WANT_VOID;
3010             break;
3011         case G_ARRAY:
3012             if (flags & AMGf_want_list) {
3013                 myop.op_flags |= OPf_WANT_LIST;
3014                 break;
3015             }
3016             /* FALLTHROUGH */
3017         default:
3018             myop.op_flags |= OPf_WANT_SCALAR;
3019             break;
3020     }
3021
3022     PUSHSTACKi(PERLSI_OVERLOAD);
3023     ENTER;
3024     SAVEOP();
3025     PL_op = (OP *) &myop;
3026     if (PERLDB_SUB && PL_curstash != PL_debstash)
3027         PL_op->op_private |= OPpENTERSUB_DB;
3028     PUTBACK;
3029     Perl_pp_pushmark(aTHX);
3030
3031     EXTEND(SP, notfound + 5);
3032     PUSHs(lr>0? right: left);
3033     PUSHs(lr>0? left: right);
3034     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3035     if (notfound) {
3036       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3037                            AMG_id2namelen(method + assignshift), SVs_TEMP));
3038     }
3039     PUSHs(MUTABLE_SV(cv));
3040     PUTBACK;
3041     oldmark = TOPMARK;
3042
3043     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3044       CALLRUNOPS(aTHX);
3045     LEAVE;
3046     SPAGAIN;
3047     nret = SP - (PL_stack_base + oldmark);
3048
3049     switch (gimme) {
3050         case G_VOID:
3051             /* returning NULL has another meaning, and we check the context
3052              * at the call site too, so this can be differentiated from the
3053              * scalar case */
3054             res = &PL_sv_undef;
3055             SP = PL_stack_base + oldmark;
3056             break;
3057         case G_ARRAY: {
3058             if (flags & AMGf_want_list) {
3059                 res = sv_2mortal((SV *)newAV());
3060                 av_extend((AV *)res, nret);
3061                 while (nret--)
3062                     av_store((AV *)res, nret, POPs);
3063                 break;
3064             }
3065             /* FALLTHROUGH */
3066         }
3067         default:
3068             res = POPs;
3069             break;
3070     }
3071
3072     PUTBACK;
3073     POPSTACK;
3074     CATCH_SET(oldcatch);
3075
3076     if (postpr) {
3077       int ans;
3078       switch (method) {
3079       case le_amg:
3080       case sle_amg:
3081         ans=SvIV(res)<=0; break;
3082       case lt_amg:
3083       case slt_amg:
3084         ans=SvIV(res)<0; break;
3085       case ge_amg:
3086       case sge_amg:
3087         ans=SvIV(res)>=0; break;
3088       case gt_amg:
3089       case sgt_amg:
3090         ans=SvIV(res)>0; break;
3091       case eq_amg:
3092       case seq_amg:
3093         ans=SvIV(res)==0; break;
3094       case ne_amg:
3095       case sne_amg:
3096         ans=SvIV(res)!=0; break;
3097       case inc_amg:
3098       case dec_amg:
3099         SvSetSV(left,res); return left;
3100       case not_amg:
3101         ans=!SvTRUE(res); break;
3102       default:
3103         ans=0; break;
3104       }
3105       return boolSV(ans);
3106     } else if (method==copy_amg) {
3107       if (!SvROK(res)) {
3108         Perl_croak(aTHX_ "Copy method did not return a reference");
3109       }
3110       return SvREFCNT_inc(SvRV(res));
3111     } else {
3112       return res;
3113     }
3114   }
3115 }
3116
3117 void
3118 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3119 {
3120     dVAR;
3121     U32 hash;
3122
3123     PERL_ARGS_ASSERT_GV_NAME_SET;
3124
3125     if (len > I32_MAX)
3126         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3127
3128     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3129         unshare_hek(GvNAME_HEK(gv));
3130     }
3131
3132     PERL_HASH(hash, name, len);
3133     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3134 }
3135
3136 /*
3137 =for apidoc gv_try_downgrade
3138
3139 If the typeglob C<gv> can be expressed more succinctly, by having
3140 something other than a real GV in its place in the stash, replace it
3141 with the optimised form.  Basic requirements for this are that C<gv>
3142 is a real typeglob, is sufficiently ordinary, and is only referenced
3143 from its package.  This function is meant to be used when a GV has been
3144 looked up in part to see what was there, causing upgrading, but based
3145 on what was found it turns out that the real GV isn't required after all.
3146
3147 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3148
3149 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3150 sub, the typeglob is replaced with a scalar-reference placeholder that
3151 more compactly represents the same thing.
3152
3153 =cut
3154 */
3155
3156 void
3157 Perl_gv_try_downgrade(pTHX_ GV *gv)
3158 {
3159     HV *stash;
3160     CV *cv;
3161     HEK *namehek;
3162     SV **gvp;
3163     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3164
3165     /* XXX Why and where does this leave dangling pointers during global
3166        destruction? */
3167     if (PL_phase == PERL_PHASE_DESTRUCT) return;
3168
3169     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3170             !SvOBJECT(gv) && !SvREADONLY(gv) &&
3171             isGV_with_GP(gv) && GvGP(gv) &&
3172             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3173             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3174             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3175         return;
3176     if (SvMAGICAL(gv)) {
3177         MAGIC *mg;
3178         /* only backref magic is allowed */
3179         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3180             return;
3181         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3182             if (mg->mg_type != PERL_MAGIC_backref)
3183                 return;
3184         }
3185     }
3186     cv = GvCV(gv);
3187     if (!cv) {
3188         HEK *gvnhek = GvNAME_HEK(gv);
3189         (void)hv_delete(stash, HEK_KEY(gvnhek),
3190             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3191     } else if (GvMULTI(gv) && cv &&
3192             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3193             CvSTASH(cv) == stash && CvGV(cv) == gv &&
3194             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3195             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3196             (namehek = GvNAME_HEK(gv)) &&
3197             (gvp = hv_fetch(stash, HEK_KEY(namehek),
3198                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3199             *gvp == (SV*)gv) {
3200         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3201         SvREFCNT(gv) = 0;
3202         sv_clear((SV*)gv);
3203         SvREFCNT(gv) = 1;
3204         SvFLAGS(gv) = SVt_IV|SVf_ROK;
3205         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3206                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3207         SvRV_set(gv, value);
3208     }
3209 }
3210
3211 #include "XSUB.h"
3212
3213 static void
3214 core_xsub(pTHX_ CV* cv)
3215 {
3216     Perl_croak(aTHX_
3217        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3218     );
3219 }
3220
3221 /*
3222  * Local variables:
3223  * c-indentation-style: bsd
3224  * c-basic-offset: 4
3225  * indent-tabs-mode: nil
3226  * End:
3227  *
3228  * ex: set ts=8 sts=4 sw=4 et:
3229  */