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