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