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)
 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));
 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);
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_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
1083 {
1084     dVAR;
1085     GV* gv;
1086     CV* cv;
1087     HV* varstash;
1088     GV* vargv;
1089     SV* varsv;
1090     const char *packname = "";
1091     STRLEN packname_len = 0;
1092
1093     PERL_ARGS_ASSERT_GV_AUTOLOAD4;
1094
1095     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1096         return NULL;
1097     if (stash) {
1098         if (SvTYPE(stash) < SVt_PVHV) {
1099             packname = SvPV_const(MUTABLE_SV(stash), packname_len);
1100             stash = NULL;
1101         }
1102         else {
1103             packname = HvNAME_get(stash);
1104             packname_len = HvNAMELEN_get(stash);
1105         }
1106     }
1107     if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, 0)))
1108         return NULL;
1109     cv = GvCV(gv);
1110
1111     if (!(CvROOT(cv) || CvXSUB(cv)))
1112         return NULL;
1113
1114     /*
1115      * Inheriting AUTOLOAD for non-methods works ... for now.
1116      */
1117     if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1118     )
1119         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1120                          "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
1121                          packname, (int)len, name);
1122
1123     if (CvISXSUB(cv)) {
1124         /* rather than lookup/init $AUTOLOAD here
1125          * only to have the XSUB do another lookup for $AUTOLOAD
1126          * and split that value on the last '::',
1127          * pass along the same data via some unused fields in the CV
1128          */
1129         CvSTASH_set(cv, stash);
1130         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
1131         SvCUR_set(cv, len);
1132         return gv;
1133     }
1134
1135     /*
1136      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1137      * The subroutine's original name may not be "AUTOLOAD", so we don't
1138      * use that, but for lack of anything better we will use the sub's
1139      * original package to look up $AUTOLOAD.
1140      */
1141     varstash = GvSTASH(CvGV(cv));
1142     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1143     ENTER;
1144
1145     if (!isGV(vargv)) {
1146         gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
1147 #ifdef PERL_DONT_CREATE_GVSV
1148         GvSV(vargv) = newSV(0);
1149 #endif
1150     }
1151     LEAVE;
1152     varsv = GvSVn(vargv);
1153     sv_setpvn(varsv, packname, packname_len);
1154     sv_catpvs(varsv, "::");
1155     /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1156        tainting if $FOO::AUTOLOAD was previously tainted, but is not now.  */
1157     sv_catpvn_mg(varsv, name, len);
1158     return gv;
1159 }
1160
1161
1162 /* require_tie_mod() internal routine for requiring a module
1163  * that implements the logic of automatic ties like %! and %-
1164  *
1165  * The "gv" parameter should be the glob.
1166  * "varpv" holds the name of the var, used for error messages.
1167  * "namesv" holds the module name. Its refcount will be decremented.
1168  * "methpv" holds the method name to test for to check that things
1169  *   are working reasonably close to as expected.
1170  * "flags": if flag & 1 then save the scalar before loading.
1171  * For the protection of $! to work (it is set by this routine)
1172  * the sv slot must already be magicalized.
1173  */
1174 STATIC HV*
1175 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1176 {
1177     dVAR;
1178     HV* stash = gv_stashsv(namesv, 0);
1179
1180     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1181
1182     if (!stash || !(gv_fetchmethod(stash, methpv))) {
1183         SV *module = newSVsv(namesv);
1184         char varname = *varpv; /* varpv might be clobbered by load_module,
1185                                   so save it. For the moment it's always
1186                                   a single char. */
1187         dSP;
1188         ENTER;
1189         if ( flags & 1 )
1190             save_scalar(gv);
1191         PUSHSTACKi(PERLSI_MAGIC);
1192         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1193         POPSTACK;
1194         LEAVE;
1195         SPAGAIN;
1196         stash = gv_stashsv(namesv, 0);
1197         if (!stash)
1198             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
1199                     varname, SVfARG(namesv));
1200         else if (!gv_fetchmethod(stash, methpv))
1201             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
1202                     varname, SVfARG(namesv), methpv);
1203     }
1204     SvREFCNT_dec(namesv);
1205     return stash;
1206 }
1207
1208 /*
1209 =for apidoc gv_stashpv
1210
1211 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
1212 determine the length of C<name>, then calls C<gv_stashpvn()>.
1213
1214 =cut
1215 */
1216
1217 HV*
1218 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1219 {
1220     PERL_ARGS_ASSERT_GV_STASHPV;
1221     return gv_stashpvn(name, strlen(name), create);
1222 }
1223
1224 /*
1225 =for apidoc gv_stashpvn
1226
1227 Returns a pointer to the stash for a specified package.  The C<namelen>
1228 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
1229 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1230 created if it does not already exist.  If the package does not exist and
1231 C<flags> is 0 (or any other setting that does not create packages) then NULL
1232 is returned.
1233
1234
1235 =cut
1236 */
1237
1238 HV*
1239 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1240 {
1241     char smallbuf[128];
1242     char *tmpbuf;
1243     HV *stash;
1244     GV *tmpgv;
1245     U32 tmplen = namelen + 2;
1246
1247     PERL_ARGS_ASSERT_GV_STASHPVN;
1248
1249     if (tmplen <= sizeof smallbuf)
1250         tmpbuf = smallbuf;
1251     else
1252         Newx(tmpbuf, tmplen, char);
1253     Copy(name, tmpbuf, namelen, char);
1254     tmpbuf[namelen]   = ':';
1255     tmpbuf[namelen+1] = ':';
1256     tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1257     if (tmpbuf != smallbuf)
1258         Safefree(tmpbuf);
1259     if (!tmpgv)
1260         return NULL;
1261     stash = GvHV(tmpgv);
1262     if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1263     assert(stash);
1264     if (!HvNAME_get(stash)) {
1265         hv_name_set(stash, name, namelen, 0);
1266
1267         /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1268         /* If the containing stash has multiple effective
1269            names, see that this one gets them, too. */
1270         if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1271             mro_package_moved(stash, NULL, tmpgv, 1);
1272     }
1273     return stash;
1274 }
1275
1276 /*
1277 =for apidoc gv_stashsv
1278
1279 Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
1280
1281 =cut
1282 */
1283
1284 HV*
1285 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1286 {
1287     STRLEN len;
1288     const char * const ptr = SvPV_const(sv,len);
1289
1290     PERL_ARGS_ASSERT_GV_STASHSV;
1291
1292     return gv_stashpvn(ptr, len, flags);
1293 }
1294
1295
1296 GV *
1297 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1298     PERL_ARGS_ASSERT_GV_FETCHPV;
1299     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1300 }
1301
1302 GV *
1303 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1304     STRLEN len;
1305     const char * const nambeg =
1306        SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1307     PERL_ARGS_ASSERT_GV_FETCHSV;
1308     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1309 }
1310
1311 STATIC void
1312 S_gv_magicalize_isa(pTHX_ GV *gv)
1313 {
1314     AV* av;
1315
1316     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1317
1318     av = GvAVn(gv);
1319     GvMULTI_on(gv);
1320     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1321              NULL, 0);
1322 }
1323
1324 STATIC void
1325 S_gv_magicalize_overload(pTHX_ GV *gv)
1326 {
1327     HV* hv;
1328
1329     PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
1330
1331     hv = GvHVn(gv);
1332     GvMULTI_on(gv);
1333     hv_magic(hv, NULL, PERL_MAGIC_overload);
1334 }
1335
1336 GV *
1337 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
1338                        const svtype sv_type)
1339 {
1340     dVAR;
1341     register const char *name = nambeg;
1342     register GV *gv = NULL;
1343     GV**gvp;
1344     I32 len;
1345     register const char *name_cursor;
1346     HV *stash = NULL;
1347     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
1348     const I32 no_expand = flags & GV_NOEXPAND;
1349     const I32 add = flags & ~GV_NOADD_MASK;
1350     bool addmg = !!(flags & GV_ADDMG);
1351     const char *const name_end = nambeg + full_len;
1352     const char *const name_em1 = name_end - 1;
1353     U32 faking_it;
1354
1355     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1356
1357     if (flags & GV_NOTQUAL) {
1358         /* Caller promised that there is no stash, so we can skip the check. */
1359         len = full_len;
1360         goto no_stash;
1361     }
1362
1363     if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
1364         /* accidental stringify on a GV? */
1365         name++;
1366     }
1367
1368     for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1369         if (name_cursor < name_em1 &&
1370             ((*name_cursor == ':'
1371              && name_cursor[1] == ':')
1372             || *name_cursor == '\''))
1373         {
1374             if (!stash)
1375                 stash = PL_defstash;
1376             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1377                 return NULL;
1378
1379             len = name_cursor - name;
1380             if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1381                 const char *key;
1382                 if (*name_cursor == ':') {
1383                     key = name;
1384                     len += 2;
1385                 } else {
1386                     char *tmpbuf;
1387                     Newx(tmpbuf, len+2, char);
1388                     Copy(name, tmpbuf, len, char);
1389                     tmpbuf[len++] = ':';
1390                     tmpbuf[len++] = ':';
1391                     key = tmpbuf;
1392                 }
1393                 gvp = (GV**)hv_fetch(stash, key, len, add);
1394                 gv = gvp ? *gvp : NULL;
1395                 if (gv && gv != (const GV *)&PL_sv_undef) {
1396                     if (SvTYPE(gv) != SVt_PVGV)
1397                         gv_init(gv, stash, key, len, (add & GV_ADDMULTI));
1398                     else
1399                         GvMULTI_on(gv);
1400                 }
1401                 if (key != name)
1402                     Safefree(key);
1403                 if (!gv || gv == (const GV *)&PL_sv_undef)
1404                     return NULL;
1405
1406                 if (!(stash = GvHV(gv)))
1407                 {
1408                     stash = GvHV(gv) = newHV();
1409                     if (!HvNAME_get(stash)) {
1410                         if (GvSTASH(gv) == PL_defstash && len == 6
1411                          && strnEQ(name, "CORE", 4))
1412                             hv_name_set(stash, "CORE", 4, 0);
1413                         else
1414                             hv_name_set(
1415                                 stash, nambeg, name_cursor-nambeg, 0
1416                             );
1417                         /* If the containing stash has multiple effective
1418                            names, see that this one gets them, too. */
1419                         if (HvAUX(GvSTASH(gv))->xhv_name_count)
1420                             mro_package_moved(stash, NULL, gv, 1);
1421                     }
1422                 }
1423                 else if (!HvNAME_get(stash))
1424                     hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
1425             }
1426
1427             if (*name_cursor == ':')
1428                 name_cursor++;
1429             name = name_cursor+1;
1430             if (name == name_end)
1431                 return gv
1432                     ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1433         }
1434     }
1435     len = name_cursor - name;
1436
1437     /* No stash in name, so see how we can default */
1438
1439     if (!stash) {
1440     no_stash:
1441         if (len && isIDFIRST_lazy(name)) {
1442             bool global = FALSE;
1443
1444             switch (len) {
1445             case 1:
1446                 if (*name == '_')
1447                     global = TRUE;
1448                 break;
1449             case 3:
1450                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1451                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1452                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1453                     global = TRUE;
1454                 break;
1455             case 4:
1456                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1457                     && name[3] == 'V')
1458                     global = TRUE;
1459                 break;
1460             case 5:
1461                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1462                     && name[3] == 'I' && name[4] == 'N')
1463                     global = TRUE;
1464                 break;
1465             case 6:
1466                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1467                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1468                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1469                     global = TRUE;
1470                 break;
1471             case 7:
1472                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1473                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1474                     && name[6] == 'T')
1475                     global = TRUE;
1476                 break;
1477             }
1478
1479             if (global)
1480                 stash = PL_defstash;
1481             else if (IN_PERL_COMPILETIME) {
1482                 stash = PL_curstash;
1483                 if (add && (PL_hints & HINT_STRICT_VARS) &&
1484                     sv_type != SVt_PVCV &&
1485                     sv_type != SVt_PVGV &&
1486                     sv_type != SVt_PVFM &&
1487                     sv_type != SVt_PVIO &&
1488                     !(len == 1 && sv_type == SVt_PV &&
1489                       (*name == 'a' || *name == 'b')) )
1490                 {
1491                     gvp = (GV**)hv_fetch(stash,name,len,0);
1492                     if (!gvp ||
1493                         *gvp == (const GV *)&PL_sv_undef ||
1494                         SvTYPE(*gvp) != SVt_PVGV)
1495                     {
1496                         stash = NULL;
1497                     }
1498                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1499                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1500                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1501                     {
1502                         /* diag_listed_as: Variable "%s" is not imported%s */
1503                         Perl_ck_warner_d(
1504                             aTHX_ packWARN(WARN_MISC),
1505                             "Variable \"%c%s\" is not imported",
1506                             sv_type == SVt_PVAV ? '@' :
1507                             sv_type == SVt_PVHV ? '%' : '$',
1508                             name);
1509                         if (GvCVu(*gvp))
1510                             Perl_ck_warner_d(
1511                                 aTHX_ packWARN(WARN_MISC),
1512                                 "\t(Did you mean &%s instead?)\n", name
1513                             );
1514                         stash = NULL;
1515                     }
1516                 }
1517             }
1518             else
1519                 stash = CopSTASH(PL_curcop);
1520         }
1521         else
1522             stash = PL_defstash;
1523     }
1524
1525     /* By this point we should have a stash and a name */
1526
1527     if (!stash) {
1528         if (add) {
1529             SV * const err = Perl_mess(aTHX_
1530                  "Global symbol \"%s%s\" requires explicit package name",
1531                  (sv_type == SVt_PV ? "$"
1532                   : sv_type == SVt_PVAV ? "@"
1533                   : sv_type == SVt_PVHV ? "%"
1534                   : ""), name);
1535             GV *gv;
1536             if (USE_UTF8_IN_NAMES)
1537                 SvUTF8_on(err);
1538             qerror(err);
1539             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1540             if(!gv) {
1541                 /* symbol table under destruction */
1542                 return NULL;
1543             }
1544             stash = GvHV(gv);
1545         }
1546         else
1547             return NULL;
1548     }
1549
1550     if (!SvREFCNT(stash))       /* symbol table under destruction */
1551         return NULL;
1552
1553     gvp = (GV**)hv_fetch(stash,name,len,add);
1554     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1555         if (addmg) gv = (GV *)newSV(0);
1556         else return NULL;
1557     }
1558     else gv = *gvp, addmg = 0;
1559     /* From this point on, addmg means gv has not been inserted in the
1560        symtab yet. */
1561
1562     if (SvTYPE(gv) == SVt_PVGV) {
1563         if (add) {
1564             GvMULTI_on(gv);
1565             gv_init_svtype(gv, sv_type);
1566             if (len == 1 && stash == PL_defstash
1567                 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1568                 if (*name == '!')
1569                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1570                 else if (*name == '-' || *name == '+')
1571                     require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1572             }
1573             else if (len == 3 && sv_type == SVt_PVAV
1574                   && strnEQ(name, "ISA", 3)
1575                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1576                 gv_magicalize_isa(gv);
1577         }
1578         return gv;
1579     } else if (no_init) {
1580         assert(!addmg);
1581         return gv;
1582     } else if (no_expand && SvROK(gv)) {
1583         assert(!addmg);
1584         return gv;
1585     }
1586
1587     /* Adding a new symbol.
1588        Unless of course there was already something non-GV here, in which case
1589        we want to behave as if there was always a GV here, containing some sort
1590        of subroutine.
1591        Otherwise we run the risk of creating things like GvIO, which can cause
1592        subtle bugs. eg the one that tripped up SQL::Translator  */
1593
1594     faking_it = SvOK(gv);
1595
1596     if (add & GV_ADDWARN)
1597         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1598     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1599
1600     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1601                                             : (PL_dowarn & G_WARN_ON ) ) )
1602         GvMULTI_on(gv) ;
1603
1604     /* set up magic where warranted */
1605     if (stash != PL_defstash) { /* not the main stash */
1606         /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
1607            and VERSION. All the others apply only to the main stash or to
1608            CORE (which is checked right after this). */
1609         if (len > 2) {
1610             const char * const name2 = name + 1;
1611             switch (*name) {
1612             case 'E':
1613                 if (strnEQ(name2, "XPORT", 5))
1614                     GvMULTI_on(gv);
1615                 break;
1616             case 'I':
1617                 if (strEQ(name2, "SA"))
1618                     gv_magicalize_isa(gv);
1619                 break;
1620             case 'O':
1621                 if (strEQ(name2, "VERLOAD"))
1622                     gv_magicalize_overload(gv);
1623                 break;
1624             case 'V':
1625                 if (strEQ(name2, "ERSION"))
1626                     GvMULTI_on(gv);
1627                 break;
1628             default:
1629                 goto try_core;
1630             }
1631             goto add_magical_gv;
1632         }
1633       try_core:
1634         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1635           /* Avoid null warning: */
1636           const char * const stashname = HvNAME(stash); assert(stashname);
1637           if (strnEQ(stashname, "CORE", 4)
1638            && S_maybe_add_coresub(aTHX_
1639                 addmg ? stash : 0, gv, name, len, nambeg, full_len
1640               ))
1641             addmg = 0;
1642         }
1643     }
1644     else if (len > 1) {
1645 #ifndef EBCDIC
1646         if (*name > 'V' ) {
1647             NOOP;
1648             /* Nothing else to do.
1649                The compiler will probably turn the switch statement into a
1650                branch table. Make sure we avoid even that small overhead for
1651                the common case of lower case variable names.  */
1652         } else
1653 #endif
1654         {
1655             const char * const name2 = name + 1;
1656             switch (*name) {
1657             case 'A':
1658                 if (strEQ(name2, "RGV")) {
1659                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1660                 }
1661                 else if (strEQ(name2, "RGVOUT")) {
1662                     GvMULTI_on(gv);
1663                 }
1664                 break;
1665             case 'E':
1666                 if (strnEQ(name2, "XPORT", 5))
1667                     GvMULTI_on(gv);
1668                 break;
1669             case 'I':
1670                 if (strEQ(name2, "SA")) {
1671                     gv_magicalize_isa(gv);
1672                 }
1673                 break;
1674             case 'O':
1675                 if (strEQ(name2, "VERLOAD")) {
1676                     gv_magicalize_overload(gv);
1677                 }
1678                 break;
1679             case 'S':
1680                 if (strEQ(name2, "IG")) {
1681                     HV *hv;
1682                     I32 i;
1683                     if (!PL_psig_name) {
1684                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1685                         Newxz(PL_psig_pend, SIG_SIZE, int);
1686                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1687                     } else {
1688                         /* I think that the only way to get here is to re-use an
1689                            embedded perl interpreter, where the previous
1690                            use didn't clean up fully because
1691                            PL_perl_destruct_level was 0. I'm not sure that we
1692                            "support" that, in that I suspect in that scenario
1693                            there are sufficient other garbage values left in the
1694                            interpreter structure that something else will crash
1695                            before we get here. I suspect that this is one of
1696                            those "doctor, it hurts when I do this" bugs.  */
1697                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1698                         Zero(PL_psig_pend, SIG_SIZE, int);
1699                     }
1700                     GvMULTI_on(gv);
1701                     hv = GvHVn(gv);
1702                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1703                     for (i = 1; i < SIG_SIZE; i++) {
1704                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1705                         if (init)
1706                             sv_setsv(*init, &PL_sv_undef);
1707                     }
1708                 }
1709                 break;
1710             case 'V':
1711                 if (strEQ(name2, "ERSION"))
1712                     GvMULTI_on(gv);
1713                 break;
1714             case '\003':        /* $^CHILD_ERROR_NATIVE */
1715                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1716                     goto magicalize;
1717                 break;
1718             case '\005':        /* $^ENCODING */
1719                 if (strEQ(name2, "NCODING"))
1720                     goto magicalize;
1721                 break;
1722             case '\007':        /* $^GLOBAL_PHASE */
1723                 if (strEQ(name2, "LOBAL_PHASE"))
1724                     goto ro_magicalize;
1725                 break;
1726             case '\015':        /* $^MATCH */
1727                 if (strEQ(name2, "ATCH"))
1728                     goto magicalize;
1729             case '\017':        /* $^OPEN */
1730                 if (strEQ(name2, "PEN"))
1731                     goto magicalize;
1732                 break;
1733             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1734                 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1735                     goto magicalize;
1736                 break;
1737             case '\024':        /* ${^TAINT} */
1738                 if (strEQ(name2, "AINT"))
1739                     goto ro_magicalize;
1740                 break;
1741             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1742                 if (strEQ(name2, "NICODE"))
1743                     goto ro_magicalize;
1744                 if (strEQ(name2, "TF8LOCALE"))
1745                     goto ro_magicalize;
1746                 if (strEQ(name2, "TF8CACHE"))
1747                     goto magicalize;
1748                 break;
1749             case '\027':        /* $^WARNING_BITS */
1750                 if (strEQ(name2, "ARNING_BITS"))
1751                     goto magicalize;
1752                 break;
1753             case '1':
1754             case '2':
1755             case '3':
1756             case '4':
1757             case '5':
1758             case '6':
1759             case '7':
1760             case '8':
1761             case '9':
1762             {
1763                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1764                    this test  */
1765                 /* This snippet is taken from is_gv_magical */
1766                 const char *end = name + len;
1767                 while (--end > name) {
1768                     if (!isDIGIT(*end)) goto add_magical_gv;
1769                 }
1770                 goto magicalize;
1771             }
1772             }
1773         }
1774     } else {
1775         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1776            be case '\0' in this switch statement (ie a default case)  */
1777         switch (*name) {
1778         case '&':               /* $& */
1779         case '`':               /* $` */
1780         case '\'':              /* $' */
1781             if (
1782                 sv_type == SVt_PVAV ||
1783                 sv_type == SVt_PVHV ||
1784                 sv_type == SVt_PVCV ||
1785                 sv_type == SVt_PVFM ||
1786                 sv_type == SVt_PVIO
1787                 ) { break; }
1788             PL_sawampersand = TRUE;
1789             goto magicalize;
1790
1791         case ':':               /* $: */
1792             sv_setpv(GvSVn(gv),PL_chopset);
1793             goto magicalize;
1794
1795         case '?':               /* $? */
1796 #ifdef COMPLEX_STATUS
1797             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1798 #endif
1799             goto magicalize;
1800
1801         case '!':               /* $! */
1802             GvMULTI_on(gv);
1803             /* If %! has been used, automatically load Errno.pm. */
1804
1805             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1806
1807             /* magicalization must be done before require_tie_mod is called */
1808             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1809                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1810
1811             break;
1812         case '-':               /* $- */
1813         case '+':               /* $+ */
1814         GvMULTI_on(gv); /* no used once warnings here */
1815         {
1816             AV* const av = GvAVn(gv);
1817             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1818
1819             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1820             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1821             if (avc)
1822                 SvREADONLY_on(GvSVn(gv));
1823             SvREADONLY_on(av);
1824
1825             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1826                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1827
1828             break;
1829         }
1830         case '*':               /* $* */
1831         case '#':               /* $# */
1832             if (sv_type == SVt_PV)
1833                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1834                                  "$%c is no longer supported", *name);
1835             break;
1836         case '|':               /* $| */
1837             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1838             goto magicalize;
1839
1840         case '\010':    /* $^H */
1841             {
1842                 HV *const hv = GvHVn(gv);
1843                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1844             }
1845             goto magicalize;
1846         case '\023':    /* $^S */
1847         ro_magicalize:
1848             SvREADONLY_on(GvSVn(gv));
1849             /* FALL THROUGH */
1850         case '0':               /* $0 */
1851         case '1':               /* $1 */
1852         case '2':               /* $2 */
1853         case '3':               /* $3 */
1854         case '4':               /* $4 */
1855         case '5':               /* $5 */
1856         case '6':               /* $6 */
1857         case '7':               /* $7 */
1858         case '8':               /* $8 */
1859         case '9':               /* $9 */
1860         case '[':               /* $[ */
1861         case '^':               /* $^ */
1862         case '~':               /* $~ */
1863         case '=':               /* $= */
1864         case '%':               /* $% */
1865         case '.':               /* $. */
1866         case '(':               /* $( */
1867         case ')':               /* $) */
1868         case '<':               /* $< */
1869         case '>':               /* $> */
1870         case '\\':              /* $\ */
1871         case '/':               /* $/ */
1872         case '$':               /* $$ */
1873         case '\001':    /* $^A */
1874         case '\003':    /* $^C */
1875         case '\004':    /* $^D */
1876         case '\005':    /* $^E */
1877         case '\006':    /* $^F */
1878         case '\011':    /* $^I, NOT \t in EBCDIC */
1879         case '\016':    /* $^N */
1880         case '\017':    /* $^O */
1881         case '\020':    /* $^P */
1882         case '\024':    /* $^T */
1883         case '\027':    /* $^W */
1884         magicalize:
1885             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1886             break;
1887
1888         case '\014':    /* $^L */
1889             sv_setpvs(GvSVn(gv),"\f");
1890             PL_formfeed = GvSVn(gv);
1891             break;
1892         case ';':               /* $; */
1893             sv_setpvs(GvSVn(gv),"\034");
1894             break;
1895         case ']':               /* $] */
1896         {
1897             SV * const sv = GvSV(gv);
1898             if (!sv_derived_from(PL_patchlevel, "version"))
1899                 upg_version(PL_patchlevel, TRUE);
1900             GvSV(gv) = vnumify(PL_patchlevel);
1901             SvREADONLY_on(GvSV(gv));
1902             SvREFCNT_dec(sv);
1903         }
1904         break;
1905         case '\026':    /* $^V */
1906         {
1907             SV * const sv = GvSV(gv);
1908             GvSV(gv) = new_version(PL_patchlevel);
1909             SvREADONLY_on(GvSV(gv));
1910             SvREFCNT_dec(sv);
1911         }
1912         break;
1913         }
1914     }
1915   add_magical_gv:
1916     if (addmg) {
1917         if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
1918              GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
1919            ))
1920             (void)hv_store(stash,name,len,(SV *)gv,0);
1921         else SvREFCNT_dec(gv), gv = NULL;
1922     }
1923     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
1924     return gv;
1925 }
1926
1927 void
1928 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1929 {
1930     const char *name;
1931     STRLEN namelen;
1932     const HV * const hv = GvSTASH(gv);
1933
1934     PERL_ARGS_ASSERT_GV_FULLNAME4;
1935
1936     if (!hv) {
1937         SvOK_off(sv);
1938         return;
1939     }
1940     sv_setpv(sv, prefix ? prefix : "");
1941
1942     name = HvNAME_get(hv);
1943     if (name) {
1944         namelen = HvNAMELEN_get(hv);
1945     } else {
1946         name = "__ANON__";
1947         namelen = 8;
1948     }
1949
1950     if (keepmain || strNE(name, "main")) {
1951         sv_catpvn(sv,name,namelen);
1952         sv_catpvs(sv,"::");
1953     }
1954     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1955 }
1956
1957 void
1958 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1959 {
1960     const GV * const egv = GvEGVx(gv);
1961
1962     PERL_ARGS_ASSERT_GV_EFULLNAME4;
1963
1964     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1965 }
1966
1967 void
1968 Perl_gv_check(pTHX_ const HV *stash)
1969 {
1970     dVAR;
1971     register I32 i;
1972
1973     PERL_ARGS_ASSERT_GV_CHECK;
1974
1975     if (!HvARRAY(stash))
1976         return;
1977     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1978         const HE *entry;
1979         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1980             register GV *gv;
1981             HV *hv;
1982             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1983                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
1984             {
1985                 if (hv != PL_defstash && hv != stash)
1986                      gv_check(hv);              /* nested package */
1987             }
1988             else if (isALPHA(*HeKEY(entry))) {
1989                 const char *file;
1990                 gv = MUTABLE_GV(HeVAL(entry));
1991                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1992                     continue;
1993                 file = GvFILE(gv);
1994                 CopLINE_set(PL_curcop, GvLINE(gv));
1995 #ifdef USE_ITHREADS
1996                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1997 #else
1998                 CopFILEGV(PL_curcop)
1999                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2000 #endif
2001                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2002                         "Name \"%s::%s\" used only once: possible typo",
2003                         HvNAME_get(stash), GvNAME(gv));
2004             }
2005         }
2006     }
2007 }
2008
2009 GV *
2010 Perl_newGVgen(pTHX_ const char *pack)
2011 {
2012     dVAR;
2013
2014     PERL_ARGS_ASSERT_NEWGVGEN;
2015
2016     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
2017                       GV_ADD, SVt_PVGV);
2018 }
2019
2020 /* hopefully this is only called on local symbol table entries */
2021
2022 GP*
2023 Perl_gp_ref(pTHX_ GP *gp)
2024 {
2025     dVAR;
2026     if (!gp)
2027         return NULL;
2028     gp->gp_refcnt++;
2029     if (gp->gp_cv) {
2030         if (gp->gp_cvgen) {
2031             /* If the GP they asked for a reference to contains
2032                a method cache entry, clear it first, so that we
2033                don't infect them with our cached entry */
2034             SvREFCNT_dec(gp->gp_cv);
2035             gp->gp_cv = NULL;
2036             gp->gp_cvgen = 0;
2037         }
2038     }
2039     return gp;
2040 }
2041
2042 void
2043 Perl_gp_free(pTHX_ GV *gv)
2044 {
2045     dVAR;
2046     GP* gp;
2047     int attempts = 100;
2048
2049     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2050         return;
2051     if (gp->gp_refcnt == 0) {
2052         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2053                          "Attempt to free unreferenced glob pointers"
2054                          pTHX__FORMAT pTHX__VALUE);
2055         return;
2056     }
2057     if (--gp->gp_refcnt > 0) {
2058         if (gp->gp_egv == gv)
2059             gp->gp_egv = 0;
2060         GvGP_set(gv, NULL);
2061         return;
2062     }
2063
2064     while (1) {
2065       /* Copy and null out all the glob slots, so destructors do not see
2066          freed SVs. */
2067       HEK * const file_hek = gp->gp_file_hek;
2068       SV  * const sv       = gp->gp_sv;
2069       AV  * const av       = gp->gp_av;
2070       HV  * const hv       = gp->gp_hv;
2071       IO  * const io       = gp->gp_io;
2072       CV  * const cv       = gp->gp_cv;
2073       CV  * const form     = gp->gp_form;
2074
2075       gp->gp_file_hek = NULL;
2076       gp->gp_sv       = NULL;
2077       gp->gp_av       = NULL;
2078       gp->gp_hv       = NULL;
2079       gp->gp_io       = NULL;
2080       gp->gp_cv       = NULL;
2081       gp->gp_form     = NULL;
2082
2083       if (file_hek)
2084         unshare_hek(file_hek);
2085
2086       SvREFCNT_dec(sv);
2087       SvREFCNT_dec(av);
2088       /* FIXME - another reference loop GV -> symtab -> GV ?
2089          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2090       if (hv && SvTYPE(hv) == SVt_PVHV) {
2091         const char *hvname = HvNAME_get(hv);
2092         if (PL_stashcache && hvname)
2093             (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
2094                       G_DISCARD);
2095         SvREFCNT_dec(hv);
2096       }
2097       SvREFCNT_dec(io);
2098       SvREFCNT_dec(cv);
2099       SvREFCNT_dec(form);
2100
2101       if (!gp->gp_file_hek
2102        && !gp->gp_sv
2103        && !gp->gp_av
2104        && !gp->gp_hv
2105        && !gp->gp_io
2106        && !gp->gp_cv
2107        && !gp->gp_form) break;
2108
2109       if (--attempts == 0) {
2110         Perl_die(aTHX_
2111           "panic: gp_free failed to free glob pointer - "
2112           "something is repeatedly re-creating entries"
2113         );
2114       }
2115     }
2116
2117     Safefree(gp);
2118     GvGP_set(gv, NULL);
2119 }
2120
2121 int
2122 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2123 {
2124     AMT * const amtp = (AMT*)mg->mg_ptr;
2125     PERL_UNUSED_ARG(sv);
2126
2127     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2128
2129     if (amtp && AMT_AMAGIC(amtp)) {
2130         int i;
2131         for (i = 1; i < NofAMmeth; i++) {
2132             CV * const cv = amtp->table[i];
2133             if (cv) {
2134                 SvREFCNT_dec(MUTABLE_SV(cv));
2135                 amtp->table[i] = NULL;
2136             }
2137         }
2138     }
2139  return 0;
2140 }
2141
2142 /* Updates and caches the CV's */
2143 /* Returns:
2144  * 1 on success and there is some overload
2145  * 0 if there is no overload
2146  * -1 if some error occurred and it couldn't croak
2147  */
2148
2149 int
2150 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2151 {
2152   dVAR;
2153   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2154   AMT amt;
2155   const struct mro_meta* stash_meta = HvMROMETA(stash);
2156   U32 newgen;
2157
2158   PERL_ARGS_ASSERT_GV_AMUPDATE;
2159
2160   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2161   if (mg) {
2162       const AMT * const amtp = (AMT*)mg->mg_ptr;
2163       if (amtp->was_ok_am == PL_amagic_generation
2164           && amtp->was_ok_sub == newgen) {
2165           return AMT_OVERLOADED(amtp) ? 1 : 0;
2166       }
2167       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2168   }
2169
2170   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2171
2172   Zero(&amt,1,AMT);
2173   amt.was_ok_am = PL_amagic_generation;
2174   amt.was_ok_sub = newgen;
2175   amt.fallback = AMGfallNO;
2176   amt.flags = 0;
2177
2178   {
2179     int filled = 0, have_ovl = 0;
2180     int i, lim = 1;
2181
2182     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2183
2184     /* Try to find via inheritance. */
2185     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2186     SV * const sv = gv ? GvSV(gv) : NULL;
2187     CV* cv;
2188
2189     if (!gv)
2190         lim = DESTROY_amg;              /* Skip overloading entries. */
2191 #ifdef PERL_DONT_CREATE_GVSV
2192     else if (!sv) {
2193         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2194     }
2195 #endif
2196     else if (SvTRUE(sv))
2197         amt.fallback=AMGfallYES;
2198     else if (SvOK(sv))
2199         amt.fallback=AMGfallNEVER;
2200
2201     for (i = 1; i < lim; i++)
2202         amt.table[i] = NULL;
2203     for (; i < NofAMmeth; i++) {
2204         const char * const cooky = PL_AMG_names[i];
2205         /* Human-readable form, for debugging: */
2206         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2207         const STRLEN l = PL_AMG_namelens[i];
2208
2209         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2210                      cp, HvNAME_get(stash)) );
2211         /* don't fill the cache while looking up!
2212            Creation of inheritance stubs in intermediate packages may
2213            conflict with the logic of runtime method substitution.
2214            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2215            then we could have created stubs for "(+0" in A and C too.
2216            But if B overloads "bool", we may want to use it for
2217            numifying instead of C's "+0". */
2218         if (i >= DESTROY_amg)
2219             gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
2220         else                            /* Autoload taken care of below */
2221             gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2222         cv = 0;
2223         if (gv && (cv = GvCV(gv))) {
2224             if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2225               const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2226               if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2227                && strEQ(hvname, "overload")) {
2228                 /* This is a hack to support autoloading..., while
2229                    knowing *which* methods were declared as overloaded. */
2230                 /* GvSV contains the name of the method. */
2231                 GV *ngv = NULL;
2232                 SV *gvsv = GvSV(gv);
2233
2234                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2235                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2236                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2237                 if (!gvsv || !SvPOK(gvsv)
2238                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
2239                                                        FALSE)))
2240                 {
2241                     /* Can be an import stub (created by "can"). */
2242                     if (destructing) {
2243                         return -1;
2244                     }
2245                     else {
2246                         const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
2247                         Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
2248                                     "in package \"%.256s\"",
2249                                    (GvCVGEN(gv) ? "Stub found while resolving"
2250                                     : "Can't resolve"),
2251                                    name, cp, HvNAME(stash));
2252                     }
2253                 }
2254                 cv = GvCV(gv = ngv);
2255               }
2256             }
2257             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2258                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2259                          GvNAME(CvGV(cv))) );
2260             filled = 1;
2261             if (i < DESTROY_amg)
2262                 have_ovl = 1;
2263         } else if (gv) {                /* Autoloaded... */
2264             cv = MUTABLE_CV(gv);
2265             filled = 1;
2266         }
2267         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2268     }
2269     if (filled) {
2270       AMT_AMAGIC_on(&amt);
2271       if (have_ovl)
2272           AMT_OVERLOADED_on(&amt);
2273       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2274                                                 (char*)&amt, sizeof(AMT));
2275       return have_ovl;
2276     }
2277   }
2278   /* Here we have no table: */
2279   /* no_table: */
2280   AMT_AMAGIC_off(&amt);
2281   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2282                                                 (char*)&amt, sizeof(AMTS));
2283   return 0;
2284 }
2285
2286
2287 CV*
2288 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2289 {
2290     dVAR;
2291     MAGIC *mg;
2292     AMT *amtp;
2293     U32 newgen;
2294     struct mro_meta* stash_meta;
2295
2296     if (!stash || !HvNAME_get(stash))
2297         return NULL;
2298
2299     stash_meta = HvMROMETA(stash);
2300     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2301
2302     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2303     if (!mg) {
2304       do_update:
2305         /* If we're looking up a destructor to invoke, we must avoid
2306          * that Gv_AMupdate croaks, because we might be dying already */
2307         if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2308             /* and if it didn't found a destructor, we fall back
2309              * to a simpler method that will only look for the
2310              * destructor instead of the whole magic */
2311             if (id == DESTROY_amg) {
2312                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2313                 if (gv)
2314                     return GvCV(gv);
2315             }
2316             return NULL;
2317         }
2318         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2319     }
2320     assert(mg);
2321     amtp = (AMT*)mg->mg_ptr;
2322     if ( amtp->was_ok_am != PL_amagic_generation
2323          || amtp->was_ok_sub != newgen )
2324         goto do_update;
2325     if (AMT_AMAGIC(amtp)) {
2326         CV * const ret = amtp->table[id];
2327         if (ret && isGV(ret)) {         /* Autoloading stab */
2328             /* Passing it through may have resulted in a warning
2329                "Inherited AUTOLOAD for a non-method deprecated", since
2330                our caller is going through a function call, not a method call.
2331                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2332             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2333
2334             if (gv && GvCV(gv))
2335                 return GvCV(gv);
2336         }
2337         return ret;
2338     }
2339
2340     return NULL;
2341 }
2342
2343
2344 /* Implement tryAMAGICun_MG macro.
2345    Do get magic, then see if the stack arg is overloaded and if so call it.
2346    Flags:
2347         AMGf_set     return the arg using SETs rather than assigning to
2348                      the targ
2349         AMGf_numeric apply sv_2num to the stack arg.
2350 */
2351
2352 bool
2353 Perl_try_amagic_un(pTHX_ int method, int flags) {
2354     dVAR;
2355     dSP;
2356     SV* tmpsv;
2357     SV* const arg = TOPs;
2358
2359     SvGETMAGIC(arg);
2360
2361     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2362                                               AMGf_noright | AMGf_unary))) {
2363         if (flags & AMGf_set) {
2364             SETs(tmpsv);
2365         }
2366         else {
2367             dTARGET;
2368             if (SvPADMY(TARG)) {
2369                 sv_setsv(TARG, tmpsv);
2370                 SETTARG;
2371             }
2372             else
2373                 SETs(tmpsv);
2374         }
2375         PUTBACK;
2376         return TRUE;
2377     }
2378
2379     if ((flags & AMGf_numeric) && SvROK(arg))
2380         *sp = sv_2num(arg);
2381     return FALSE;
2382 }
2383
2384
2385 /* Implement tryAMAGICbin_MG macro.
2386    Do get magic, then see if the two stack args are overloaded and if so
2387    call it.
2388    Flags:
2389         AMGf_set     return the arg using SETs rather than assigning to
2390                      the targ
2391         AMGf_assign  op may be called as mutator (eg +=)
2392         AMGf_numeric apply sv_2num to the stack arg.
2393 */
2394
2395 bool
2396 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2397     dVAR;
2398     dSP;
2399     SV* const left = TOPm1s;
2400     SV* const right = TOPs;
2401
2402     SvGETMAGIC(left);
2403     if (left != right)
2404         SvGETMAGIC(right);
2405
2406     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2407         SV * const tmpsv = amagic_call(left, right, method,
2408                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2409         if (tmpsv) {
2410             if (flags & AMGf_set) {
2411                 (void)POPs;
2412                 SETs(tmpsv);
2413             }
2414             else {
2415                 dATARGET;
2416                 (void)POPs;
2417                 if (opASSIGN || SvPADMY(TARG)) {
2418                     sv_setsv(TARG, tmpsv);
2419                     SETTARG;
2420                 }
2421                 else
2422                     SETs(tmpsv);
2423             }
2424             PUTBACK;
2425             return TRUE;
2426         }
2427     }
2428     if(left==right && SvGMAGICAL(left)) {
2429         SV * const left = sv_newmortal();
2430         *(sp-1) = left;
2431         /* Print the uninitialized warning now, so it includes the vari-
2432            able name. */
2433         if (!SvOK(right)) {
2434             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2435             sv_setsv_flags(left, &PL_sv_no, 0);
2436         }
2437         else sv_setsv_flags(left, right, 0);
2438         SvGETMAGIC(right);
2439     }
2440     if (flags & AMGf_numeric) {
2441         if (SvROK(TOPm1s))
2442             *(sp-1) = sv_2num(TOPm1s);
2443         if (SvROK(right))
2444             *sp     = sv_2num(right);
2445     }
2446     return FALSE;
2447 }
2448
2449 SV *
2450 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2451     SV *tmpsv = NULL;
2452
2453     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2454
2455     while (SvAMAGIC(ref) &&
2456            (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2457                                 AMGf_noright | AMGf_unary))) {
2458         if (!SvROK(tmpsv))
2459             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2460         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2461             /* Bail out if it returns us the same reference.  */
2462             return tmpsv;
2463         }
2464         ref = tmpsv;
2465     }
2466     return tmpsv ? tmpsv : ref;
2467 }
2468
2469 SV*
2470 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2471 {
2472   dVAR;
2473   MAGIC *mg;
2474   CV *cv=NULL;
2475   CV **cvp=NULL, **ocvp=NULL;
2476   AMT *amtp=NULL, *oamtp=NULL;
2477   int off = 0, off1, lr = 0, notfound = 0;
2478   int postpr = 0, force_cpy = 0;
2479   int assign = AMGf_assign & flags;
2480   const int assignshift = assign ? 1 : 0;
2481   int use_default_op = 0;
2482 #ifdef DEBUGGING
2483   int fl=0;
2484 #endif
2485   HV* stash=NULL;
2486
2487   PERL_ARGS_ASSERT_AMAGIC_CALL;
2488
2489   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2490       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2491
2492       if ( !lex_mask || !SvOK(lex_mask) )
2493           /* overloading lexically disabled */
2494           return NULL;
2495       else if ( lex_mask && SvPOK(lex_mask) ) {
2496           /* we have an entry in the hints hash, check if method has been
2497            * masked by overloading.pm */
2498           STRLEN len;
2499           const int offset = method / 8;
2500           const int bit    = method % 8;
2501           char *pv = SvPV(lex_mask, len);
2502
2503           /* Bit set, so this overloading operator is disabled */
2504           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2505               return NULL;
2506       }
2507   }
2508
2509   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2510       && (stash = SvSTASH(SvRV(left)))
2511       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2512       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2513                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2514                         : NULL))
2515       && ((cv = cvp[off=method+assignshift])
2516           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2517                                                           * usual method */
2518                   (
2519 #ifdef DEBUGGING
2520                    fl = 1,
2521 #endif
2522                    cv = cvp[off=method])))) {
2523     lr = -1;                    /* Call method for left argument */
2524   } else {
2525     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2526       int logic;
2527
2528       /* look for substituted methods */
2529       /* In all the covered cases we should be called with assign==0. */
2530          switch (method) {
2531          case inc_amg:
2532            force_cpy = 1;
2533            if ((cv = cvp[off=add_ass_amg])
2534                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2535              right = &PL_sv_yes; lr = -1; assign = 1;
2536            }
2537            break;
2538          case dec_amg:
2539            force_cpy = 1;
2540            if ((cv = cvp[off = subtr_ass_amg])
2541                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2542              right = &PL_sv_yes; lr = -1; assign = 1;
2543            }
2544            break;
2545          case bool__amg:
2546            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2547            break;
2548          case numer_amg:
2549            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2550            break;
2551          case string_amg:
2552            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2553            break;
2554          case not_amg:
2555            (void)((cv = cvp[off=bool__amg])
2556                   || (cv = cvp[off=numer_amg])
2557                   || (cv = cvp[off=string_amg]));
2558            if (cv)
2559                postpr = 1;
2560            break;
2561          case copy_amg:
2562            {
2563              /*
2564                   * SV* ref causes confusion with the interpreter variable of
2565                   * the same name
2566                   */
2567              SV* const tmpRef=SvRV(left);
2568              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2569                 /*
2570                  * Just to be extra cautious.  Maybe in some
2571                  * additional cases sv_setsv is safe, too.
2572                  */
2573                 SV* const newref = newSVsv(tmpRef);
2574                 SvOBJECT_on(newref);
2575                 /* As a bit of a source compatibility hack, SvAMAGIC() and
2576                    friends dereference an RV, to behave the same was as when
2577                    overloading was stored on the reference, not the referant.
2578                    Hence we can't use SvAMAGIC_on()
2579                 */
2580                 SvFLAGS(newref) |= SVf_AMAGIC;
2581                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2582                 return newref;
2583              }
2584            }
2585            break;
2586          case abs_amg:
2587            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2588                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2589              SV* const nullsv=sv_2mortal(newSViv(0));
2590              if (off1==lt_amg) {
2591                SV* const lessp = amagic_call(left,nullsv,
2592                                        lt_amg,AMGf_noright);
2593                logic = SvTRUE(lessp);
2594              } else {
2595                SV* const lessp = amagic_call(left,nullsv,
2596                                        ncmp_amg,AMGf_noright);
2597                logic = (SvNV(lessp) < 0);
2598              }
2599              if (logic) {
2600                if (off==subtr_amg) {
2601                  right = left;
2602                  left = nullsv;
2603                  lr = 1;
2604                }
2605              } else {
2606                return left;
2607              }
2608            }
2609            break;
2610          case neg_amg:
2611            if ((cv = cvp[off=subtr_amg])) {
2612              right = left;
2613              left = sv_2mortal(newSViv(0));
2614              lr = 1;
2615            }
2616            break;
2617          case int_amg:
2618          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2619          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2620          case regexp_amg:
2621              /* FAIL safe */
2622              return NULL;       /* Delegate operation to standard mechanisms. */
2623              break;
2624          case to_sv_amg:
2625          case to_av_amg:
2626          case to_hv_amg:
2627          case to_gv_amg:
2628          case to_cv_amg:
2629              /* FAIL safe */
2630              return left;       /* Delegate operation to standard mechanisms. */
2631              break;
2632          default:
2633            goto not_found;
2634          }
2635          if (!cv) goto not_found;
2636     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2637                && (stash = SvSTASH(SvRV(right)))
2638                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2639                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2640                           ? (amtp = (AMT*)mg->mg_ptr)->table
2641                           : NULL))
2642                && (cv = cvp[off=method])) { /* Method for right
2643                                              * argument found */
2644       lr=1;
2645     } else if (((cvp && amtp->fallback > AMGfallNEVER)
2646                 || (ocvp && oamtp->fallback > AMGfallNEVER))
2647                && !(flags & AMGf_unary)) {
2648                                 /* We look for substitution for
2649                                  * comparison operations and
2650                                  * concatenation */
2651       if (method==concat_amg || method==concat_ass_amg
2652           || method==repeat_amg || method==repeat_ass_amg) {
2653         return NULL;            /* Delegate operation to string conversion */
2654       }
2655       off = -1;
2656       switch (method) {
2657          case lt_amg:
2658          case le_amg:
2659          case gt_amg:
2660          case ge_amg:
2661          case eq_amg:
2662          case ne_amg:
2663              off = ncmp_amg;
2664              break;
2665          case slt_amg:
2666          case sle_amg:
2667          case sgt_amg:
2668          case sge_amg:
2669          case seq_amg:
2670          case sne_amg:
2671              off = scmp_amg;
2672              break;
2673          }
2674       if (off != -1) {
2675           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2676               cv = ocvp[off];
2677               lr = -1;
2678           }
2679           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2680               cv = cvp[off];
2681               lr = 1;
2682           }
2683       }
2684       if (cv)
2685           postpr = 1;
2686       else
2687           goto not_found;
2688     } else {
2689     not_found:                  /* No method found, either report or croak */
2690       switch (method) {
2691          case to_sv_amg:
2692          case to_av_amg:
2693          case to_hv_amg:
2694          case to_gv_amg:
2695          case to_cv_amg:
2696              /* FAIL safe */
2697              return left;       /* Delegate operation to standard mechanisms. */
2698              break;
2699       }
2700       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2701         notfound = 1; lr = -1;
2702       } else if (cvp && (cv=cvp[nomethod_amg])) {
2703         notfound = 1; lr = 1;
2704       } else if ((use_default_op =
2705                   (!ocvp || oamtp->fallback >= AMGfallYES)
2706                   && (!cvp || amtp->fallback >= AMGfallYES))
2707                  && !DEBUG_o_TEST) {
2708         /* Skip generating the "no method found" message.  */
2709         return NULL;
2710       } else {
2711         SV *msg;
2712         if (off==-1) off=method;
2713         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2714                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
2715                       AMG_id2name(method + assignshift),
2716                       (flags & AMGf_unary ? " " : "\n\tleft "),
2717                       SvAMAGIC(left)?
2718                         "in overloaded package ":
2719                         "has no overloaded magic",
2720                       SvAMAGIC(left)?
2721                         HvNAME_get(SvSTASH(SvRV(left))):
2722                         "",
2723                       SvAMAGIC(right)?
2724                         ",\n\tright argument in overloaded package ":
2725                         (flags & AMGf_unary
2726                          ? ""
2727                          : ",\n\tright argument has no overloaded magic"),
2728                       SvAMAGIC(right)?
2729                         HvNAME_get(SvSTASH(SvRV(right))):
2730                         ""));
2731         if (use_default_op) {
2732           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2733         } else {
2734           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2735         }
2736         return NULL;
2737       }
2738       force_cpy = force_cpy || assign;
2739     }
2740   }
2741 #ifdef DEBUGGING
2742   if (!notfound) {
2743     DEBUG_o(Perl_deb(aTHX_
2744                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2745                      AMG_id2name(off),
2746                      method+assignshift==off? "" :
2747                      " (initially \"",
2748                      method+assignshift==off? "" :
2749                      AMG_id2name(method+assignshift),
2750                      method+assignshift==off? "" : "\")",
2751                      flags & AMGf_unary? "" :
2752                      lr==1 ? " for right argument": " for left argument",
2753                      flags & AMGf_unary? " for argument" : "",
2754                      stash ? HvNAME_get(stash) : "null",
2755                      fl? ",\n\tassignment variant used": "") );
2756   }
2757 #endif
2758     /* Since we use shallow copy during assignment, we need
2759      * to dublicate the contents, probably calling user-supplied
2760      * version of copy operator
2761      */
2762     /* We need to copy in following cases:
2763      * a) Assignment form was called.
2764      *          assignshift==1,  assign==T, method + 1 == off
2765      * b) Increment or decrement, called directly.
2766      *          assignshift==0,  assign==0, method + 0 == off
2767      * c) Increment or decrement, translated to assignment add/subtr.
2768      *          assignshift==0,  assign==T,
2769      *          force_cpy == T
2770      * d) Increment or decrement, translated to nomethod.
2771      *          assignshift==0,  assign==0,
2772      *          force_cpy == T
2773      * e) Assignment form translated to nomethod.
2774      *          assignshift==1,  assign==T, method + 1 != off
2775      *          force_cpy == T
2776      */
2777     /*  off is method, method+assignshift, or a result of opcode substitution.
2778      *  In the latter case assignshift==0, so only notfound case is important.
2779      */
2780   if (( (method + assignshift == off)
2781         && (assign || (method == inc_amg) || (method == dec_amg)))
2782       || force_cpy)
2783   {
2784       /* newSVsv does not behave as advertised, so we copy missing
2785        * information by hand */
2786       SV *tmpRef = SvRV(left);
2787       SV *rv_copy;
2788       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2789           SvRV_set(left, rv_copy);
2790           SvSETMAGIC(left);
2791           SvREFCNT_dec(tmpRef);
2792       }
2793   }
2794
2795   {
2796     dSP;
2797     BINOP myop;
2798     SV* res;
2799     const bool oldcatch = CATCH_GET;
2800
2801     CATCH_SET(TRUE);
2802     Zero(&myop, 1, BINOP);
2803     myop.op_last = (OP *) &myop;
2804     myop.op_next = NULL;
2805     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2806
2807     PUSHSTACKi(PERLSI_OVERLOAD);
2808     ENTER;
2809     SAVEOP();
2810     PL_op = (OP *) &myop;
2811     if (PERLDB_SUB && PL_curstash != PL_debstash)
2812         PL_op->op_private |= OPpENTERSUB_DB;
2813     PUTBACK;
2814     Perl_pp_pushmark(aTHX);
2815
2816     EXTEND(SP, notfound + 5);
2817     PUSHs(lr>0? right: left);
2818     PUSHs(lr>0? left: right);
2819     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2820     if (notfound) {
2821       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2822                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2823     }
2824     PUSHs(MUTABLE_SV(cv));
2825     PUTBACK;
2826
2827     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2828       CALLRUNOPS(aTHX);
2829     LEAVE;
2830     SPAGAIN;
2831
2832     res=POPs;
2833     PUTBACK;
2834     POPSTACK;
2835     CATCH_SET(oldcatch);
2836
2837     if (postpr) {
2838       int ans;
2839       switch (method) {
2840       case le_amg:
2841       case sle_amg:
2842         ans=SvIV(res)<=0; break;
2843       case lt_amg:
2844       case slt_amg:
2845         ans=SvIV(res)<0; break;
2846       case ge_amg:
2847       case sge_amg:
2848         ans=SvIV(res)>=0; break;
2849       case gt_amg:
2850       case sgt_amg:
2851         ans=SvIV(res)>0; break;
2852       case eq_amg:
2853       case seq_amg:
2854         ans=SvIV(res)==0; break;
2855       case ne_amg:
2856       case sne_amg:
2857         ans=SvIV(res)!=0; break;
2858       case inc_amg:
2859       case dec_amg:
2860         SvSetSV(left,res); return left;
2861       case not_amg:
2862         ans=!SvTRUE(res); break;
2863       default:
2864         ans=0; break;
2865       }
2866       return boolSV(ans);
2867     } else if (method==copy_amg) {
2868       if (!SvROK(res)) {
2869         Perl_croak(aTHX_ "Copy method did not return a reference");
2870       }
2871       return SvREFCNT_inc(SvRV(res));
2872     } else {
2873       return res;
2874     }
2875   }
2876 }
2877
2878 void
2879 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2880 {
2881     dVAR;
2882     U32 hash;
2883
2884     PERL_ARGS_ASSERT_GV_NAME_SET;
2885     PERL_UNUSED_ARG(flags);
2886
2887     if (len > I32_MAX)
2888         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2889
2890     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2891         unshare_hek(GvNAME_HEK(gv));
2892     }
2893
2894     PERL_HASH(hash, name, len);
2895     GvNAME_HEK(gv) = share_hek(name, len, hash);
2896 }
2897
2898 /*
2899 =for apidoc gv_try_downgrade
2900
2901 If the typeglob C<gv> can be expressed more succinctly, by having
2902 something other than a real GV in its place in the stash, replace it
2903 with the optimised form.  Basic requirements for this are that C<gv>
2904 is a real typeglob, is sufficiently ordinary, and is only referenced
2905 from its package.  This function is meant to be used when a GV has been
2906 looked up in part to see what was there, causing upgrading, but based
2907 on what was found it turns out that the real GV isn't required after all.
2908
2909 If C<gv> is a completely empty typeglob, it is deleted from the stash.
2910
2911 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2912 sub, the typeglob is replaced with a scalar-reference placeholder that
2913 more compactly represents the same thing.
2914
2915 =cut
2916 */
2917
2918 void
2919 Perl_gv_try_downgrade(pTHX_ GV *gv)
2920 {
2921     HV *stash;
2922     CV *cv;
2923     HEK *namehek;
2924     SV **gvp;
2925     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
2926
2927     /* XXX Why and where does this leave dangling pointers during global
2928        destruction? */
2929     if (PL_phase == PERL_PHASE_DESTRUCT) return;
2930
2931     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
2932             !SvOBJECT(gv) && !SvREADONLY(gv) &&
2933             isGV_with_GP(gv) && GvGP(gv) &&
2934             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
2935             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
2936             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2937         return;
2938     if (SvMAGICAL(gv)) {
2939         MAGIC *mg;
2940         /* only backref magic is allowed */
2941         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
2942             return;
2943         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
2944             if (mg->mg_type != PERL_MAGIC_backref)
2945                 return;
2946         }
2947     }
2948     cv = GvCV(gv);
2949     if (!cv) {
2950         HEK *gvnhek = GvNAME_HEK(gv);
2951         (void)hv_delete(stash, HEK_KEY(gvnhek),
2952             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
2953     } else if (GvMULTI(gv) && cv &&
2954             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
2955             CvSTASH(cv) == stash && CvGV(cv) == gv &&
2956             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
2957             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
2958             (namehek = GvNAME_HEK(gv)) &&
2959             (gvp = hv_fetch(stash, HEK_KEY(namehek),
2960                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
2961             *gvp == (SV*)gv) {
2962         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
2963         SvREFCNT(gv) = 0;
2964         sv_clear((SV*)gv);
2965         SvREFCNT(gv) = 1;
2966         SvFLAGS(gv) = SVt_IV|SVf_ROK;
2967         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
2968                                 STRUCT_OFFSET(XPVIV, xiv_iv));
2969         SvRV_set(gv, value);
2970     }
2971 }
2972
2973 #include "XSUB.h"
2974
2975 static void
2976 core_xsub(pTHX_ CV* cv)
2977 {
2978     Perl_croak(aTHX_
2979        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
2980     );
2981 }
2982
2983 /*
2984  * Local variables:
2985  * c-indentation-style: bsd
2986  * c-basic-offset: 4
2987  * indent-tabs-mode: t
2988  * End:
2989  *
2990  * ex: set ts=8 sts=4 sw=4 noet:
2991  */