gv.c

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