gv.c

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