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