gv.c

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