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