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 ? -(*len) : *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 ? -len : 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 ? -len : 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 void
2257 Perl_gv_check(pTHX_ HV *stash)
2258 {
2259     dVAR;
2260     I32 i;
2261
2262     PERL_ARGS_ASSERT_GV_CHECK;
2263
2264     if (!HvARRAY(stash))
2265         return;
2266     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2267         const HE *entry;
2268         /* SvIsCOW is unused on HVs, so we can use it to mark stashes we
2269            are currently searching through recursively.  */
2270         SvIsCOW_on(stash);
2271         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2272             GV *gv;
2273             HV *hv;
2274             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2275                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2276             {
2277                 if (hv != PL_defstash && hv != stash && !SvIsCOW(hv))
2278                      gv_check(hv);              /* nested package */
2279             }
2280             else if ( *HeKEY(entry) != '_'
2281                         && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2282                 const char *file;
2283                 gv = MUTABLE_GV(HeVAL(entry));
2284                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2285                     continue;
2286                 file = GvFILE(gv);
2287                 CopLINE_set(PL_curcop, GvLINE(gv));
2288 #ifdef USE_ITHREADS
2289                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
2290 #else
2291                 CopFILEGV(PL_curcop)
2292                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2293 #endif
2294                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2295                         "Name \"%"HEKf"::%"HEKf
2296                         "\" used only once: possible typo",
2297                             HEKfARG(HvNAME_HEK(stash)),
2298                             HEKfARG(GvNAME_HEK(gv)));
2299             }
2300         }
2301         SvIsCOW_off(stash);
2302     }
2303 }
2304
2305 GV *
2306 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2307 {
2308     dVAR;
2309     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2310     assert(!(flags & ~SVf_UTF8));
2311
2312     return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
2313                                 UTF8fARG(flags, strlen(pack), pack),
2314                                 (long)PL_gensym++),
2315                       GV_ADD, SVt_PVGV);
2316 }
2317
2318 /* hopefully this is only called on local symbol table entries */
2319
2320 GP*
2321 Perl_gp_ref(pTHX_ GP *gp)
2322 {
2323     dVAR;
2324     if (!gp)
2325         return NULL;
2326     gp->gp_refcnt++;
2327     if (gp->gp_cv) {
2328         if (gp->gp_cvgen) {
2329             /* If the GP they asked for a reference to contains
2330                a method cache entry, clear it first, so that we
2331                don't infect them with our cached entry */
2332             SvREFCNT_dec_NN(gp->gp_cv);
2333             gp->gp_cv = NULL;
2334             gp->gp_cvgen = 0;
2335         }
2336     }
2337     return gp;
2338 }
2339
2340 void
2341 Perl_gp_free(pTHX_ GV *gv)
2342 {
2343     dVAR;
2344     GP* gp;
2345     int attempts = 100;
2346
2347     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2348         return;
2349     if (gp->gp_refcnt == 0) {
2350         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2351                          "Attempt to free unreferenced glob pointers"
2352                          pTHX__FORMAT pTHX__VALUE);
2353         return;
2354     }
2355     if (gp->gp_refcnt > 1) {
2356        borrowed:
2357         if (gp->gp_egv == gv)
2358             gp->gp_egv = 0;
2359         gp->gp_refcnt--;
2360         GvGP_set(gv, NULL);
2361         return;
2362     }
2363
2364     while (1) {
2365       /* Copy and null out all the glob slots, so destructors do not see
2366          freed SVs. */
2367       HEK * const file_hek = gp->gp_file_hek;
2368       SV  * const sv       = gp->gp_sv;
2369       AV  * const av       = gp->gp_av;
2370       HV  * const hv       = gp->gp_hv;
2371       IO  * const io       = gp->gp_io;
2372       CV  * const cv       = gp->gp_cv;
2373       CV  * const form     = gp->gp_form;
2374
2375       gp->gp_file_hek = NULL;
2376       gp->gp_sv       = NULL;
2377       gp->gp_av       = NULL;
2378       gp->gp_hv       = NULL;
2379       gp->gp_io       = NULL;
2380       gp->gp_cv       = NULL;
2381       gp->gp_form     = NULL;
2382
2383       if (file_hek)
2384         unshare_hek(file_hek);
2385
2386       SvREFCNT_dec(sv);
2387       SvREFCNT_dec(av);
2388       /* FIXME - another reference loop GV -> symtab -> GV ?
2389          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2390       if (hv && SvTYPE(hv) == SVt_PVHV) {
2391         const HEK *hvname_hek = HvNAME_HEK(hv);
2392         DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek));
2393         if (PL_stashcache && hvname_hek)
2394            (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2395         SvREFCNT_dec(hv);
2396       }
2397       SvREFCNT_dec(io);
2398       SvREFCNT_dec(cv);
2399       SvREFCNT_dec(form);
2400
2401       /* Possibly reallocated by a destructor */
2402       gp = GvGP(gv);
2403
2404       if (!gp->gp_file_hek
2405        && !gp->gp_sv
2406        && !gp->gp_av
2407        && !gp->gp_hv
2408        && !gp->gp_io
2409        && !gp->gp_cv
2410        && !gp->gp_form) break;
2411
2412       if (--attempts == 0) {
2413         Perl_die(aTHX_
2414           "panic: gp_free failed to free glob pointer - "
2415           "something is repeatedly re-creating entries"
2416         );
2417       }
2418     }
2419
2420     /* Possibly incremented by a destructor doing glob assignment */
2421     if (gp->gp_refcnt > 1) goto borrowed;
2422     Safefree(gp);
2423     GvGP_set(gv, NULL);
2424 }
2425
2426 int
2427 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2428 {
2429     AMT * const amtp = (AMT*)mg->mg_ptr;
2430     PERL_UNUSED_ARG(sv);
2431
2432     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2433
2434     if (amtp && AMT_AMAGIC(amtp)) {
2435         int i;
2436         for (i = 1; i < NofAMmeth; i++) {
2437             CV * const cv = amtp->table[i];
2438             if (cv) {
2439                 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2440                 amtp->table[i] = NULL;
2441             }
2442         }
2443     }
2444  return 0;
2445 }
2446
2447 /* Updates and caches the CV's */
2448 /* Returns:
2449  * 1 on success and there is some overload
2450  * 0 if there is no overload
2451  * -1 if some error occurred and it couldn't croak
2452  */
2453
2454 int
2455 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2456 {
2457   dVAR;
2458   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2459   AMT amt;
2460   const struct mro_meta* stash_meta = HvMROMETA(stash);
2461   U32 newgen;
2462
2463   PERL_ARGS_ASSERT_GV_AMUPDATE;
2464
2465   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2466   if (mg) {
2467       const AMT * const amtp = (AMT*)mg->mg_ptr;
2468       if (amtp->was_ok_sub == newgen) {
2469           return AMT_AMAGIC(amtp) ? 1 : 0;
2470       }
2471       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2472   }
2473
2474   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2475
2476   Zero(&amt,1,AMT);
2477   amt.was_ok_sub = newgen;
2478   amt.fallback = AMGfallNO;
2479   amt.flags = 0;
2480
2481   {
2482     int filled = 0;
2483     int i;
2484
2485     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2486
2487     /* Try to find via inheritance. */
2488     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2489     SV * const sv = gv ? GvSV(gv) : NULL;
2490     CV* cv;
2491
2492     if (!gv)
2493     {
2494       if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2495         goto no_table;
2496     }
2497 #ifdef PERL_DONT_CREATE_GVSV
2498     else if (!sv) {
2499         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2500     }
2501 #endif
2502     else if (SvTRUE(sv))
2503         /* don't need to set overloading here because fallback => 1
2504          * is the default setting for classes without overloading */
2505         amt.fallback=AMGfallYES;
2506     else if (SvOK(sv)) {
2507         amt.fallback=AMGfallNEVER;
2508         filled = 1;
2509     }
2510     else {
2511         filled = 1;
2512     }
2513
2514     for (i = 1; i < NofAMmeth; i++) {
2515         const char * const cooky = PL_AMG_names[i];
2516         /* Human-readable form, for debugging: */
2517         const char * const cp = AMG_id2name(i);
2518         const STRLEN l = PL_AMG_namelens[i];
2519
2520         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2521                      cp, HvNAME_get(stash)) );
2522         /* don't fill the cache while looking up!
2523            Creation of inheritance stubs in intermediate packages may
2524            conflict with the logic of runtime method substitution.
2525            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2526            then we could have created stubs for "(+0" in A and C too.
2527            But if B overloads "bool", we may want to use it for
2528            numifying instead of C's "+0". */
2529         gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2530         cv = 0;
2531         if (gv && (cv = GvCV(gv))) {
2532             if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2533               const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2534               if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2535                && strEQ(hvname, "overload")) {
2536                 /* This is a hack to support autoloading..., while
2537                    knowing *which* methods were declared as overloaded. */
2538                 /* GvSV contains the name of the method. */
2539                 GV *ngv = NULL;
2540                 SV *gvsv = GvSV(gv);
2541
2542                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2543                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2544                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2545                 if (!gvsv || !SvPOK(gvsv)
2546                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2547                 {
2548                     /* Can be an import stub (created by "can"). */
2549                     if (destructing) {
2550                         return -1;
2551                     }
2552                     else {
2553                         const SV * const name = (gvsv && SvPOK(gvsv))
2554                                                     ? gvsv
2555                                                     : newSVpvs_flags("???", SVs_TEMP);
2556                         /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2557                         Perl_croak(aTHX_ "%s method \"%"SVf256
2558                                     "\" overloading \"%s\" "\
2559                                     "in package \"%"HEKf256"\"",
2560                                    (GvCVGEN(gv) ? "Stub found while resolving"
2561                                     : "Can't resolve"),
2562                                    SVfARG(name), cp,
2563                                    HEKfARG(
2564                                         HvNAME_HEK(stash)
2565                                    ));
2566                     }
2567                 }
2568                 cv = GvCV(gv = ngv);
2569               }
2570             }
2571             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2572                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2573                          GvNAME(CvGV(cv))) );
2574             filled = 1;
2575         } else if (gv) {                /* Autoloaded... */
2576             cv = MUTABLE_CV(gv);
2577             filled = 1;
2578         }
2579         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2580     }
2581     if (filled) {
2582       AMT_AMAGIC_on(&amt);
2583       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2584                                                 (char*)&amt, sizeof(AMT));
2585       return TRUE;
2586     }
2587   }
2588   /* Here we have no table: */
2589  no_table:
2590   AMT_AMAGIC_off(&amt);
2591   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2592                                                 (char*)&amt, sizeof(AMTS));
2593   return 0;
2594 }
2595
2596
2597 CV*
2598 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2599 {
2600     dVAR;
2601     MAGIC *mg;
2602     AMT *amtp;
2603     U32 newgen;
2604     struct mro_meta* stash_meta;
2605
2606     if (!stash || !HvNAME_get(stash))
2607         return NULL;
2608
2609     stash_meta = HvMROMETA(stash);
2610     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2611
2612     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2613     if (!mg) {
2614       do_update:
2615         if (Gv_AMupdate(stash, 0) == -1)
2616             return NULL;
2617         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2618     }
2619     assert(mg);
2620     amtp = (AMT*)mg->mg_ptr;
2621     if ( amtp->was_ok_sub != newgen )
2622         goto do_update;
2623     if (AMT_AMAGIC(amtp)) {
2624         CV * const ret = amtp->table[id];
2625         if (ret && isGV(ret)) {         /* Autoloading stab */
2626             /* Passing it through may have resulted in a warning
2627                "Inherited AUTOLOAD for a non-method deprecated", since
2628                our caller is going through a function call, not a method call.
2629                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2630             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2631
2632             if (gv && GvCV(gv))
2633                 return GvCV(gv);
2634         }
2635         return ret;
2636     }
2637
2638     return NULL;
2639 }
2640
2641
2642 /* Implement tryAMAGICun_MG macro.
2643    Do get magic, then see if the stack arg is overloaded and if so call it.
2644    Flags:
2645         AMGf_set     return the arg using SETs rather than assigning to
2646                      the targ
2647         AMGf_numeric apply sv_2num to the stack arg.
2648 */
2649
2650 bool
2651 Perl_try_amagic_un(pTHX_ int method, int flags) {
2652     dVAR;
2653     dSP;
2654     SV* tmpsv;
2655     SV* const arg = TOPs;
2656
2657     SvGETMAGIC(arg);
2658
2659     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2660                                               AMGf_noright | AMGf_unary))) {
2661         if (flags & AMGf_set) {
2662             SETs(tmpsv);
2663         }
2664         else {
2665             dTARGET;
2666             if (SvPADMY(TARG)) {
2667                 sv_setsv(TARG, tmpsv);
2668                 SETTARG;
2669             }
2670             else
2671                 SETs(tmpsv);
2672         }
2673         PUTBACK;
2674         return TRUE;
2675     }
2676
2677     if ((flags & AMGf_numeric) && SvROK(arg))
2678         *sp = sv_2num(arg);
2679     return FALSE;
2680 }
2681
2682
2683 /* Implement tryAMAGICbin_MG macro.
2684    Do get magic, then see if the two stack args are overloaded and if so
2685    call it.
2686    Flags:
2687         AMGf_set     return the arg using SETs rather than assigning to
2688                      the targ
2689         AMGf_assign  op may be called as mutator (eg +=)
2690         AMGf_numeric apply sv_2num to the stack arg.
2691 */
2692
2693 bool
2694 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2695     dVAR;
2696     dSP;
2697     SV* const left = TOPm1s;
2698     SV* const right = TOPs;
2699
2700     SvGETMAGIC(left);
2701     if (left != right)
2702         SvGETMAGIC(right);
2703
2704     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2705         SV * const tmpsv = amagic_call(left, right, method,
2706                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2707         if (tmpsv) {
2708             if (flags & AMGf_set) {
2709                 (void)POPs;
2710                 SETs(tmpsv);
2711             }
2712             else {
2713                 dATARGET;
2714                 (void)POPs;
2715                 if (opASSIGN || SvPADMY(TARG)) {
2716                     sv_setsv(TARG, tmpsv);
2717                     SETTARG;
2718                 }
2719                 else
2720                     SETs(tmpsv);
2721             }
2722             PUTBACK;
2723             return TRUE;
2724         }
2725     }
2726     if(left==right && SvGMAGICAL(left)) {
2727         SV * const left = sv_newmortal();
2728         *(sp-1) = left;
2729         /* Print the uninitialized warning now, so it includes the vari-
2730            able name. */
2731         if (!SvOK(right)) {
2732             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2733             sv_setsv_flags(left, &PL_sv_no, 0);
2734         }
2735         else sv_setsv_flags(left, right, 0);
2736         SvGETMAGIC(right);
2737     }
2738     if (flags & AMGf_numeric) {
2739         if (SvROK(TOPm1s))
2740             *(sp-1) = sv_2num(TOPm1s);
2741         if (SvROK(right))
2742             *sp     = sv_2num(right);
2743     }
2744     return FALSE;
2745 }
2746
2747 SV *
2748 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2749     SV *tmpsv = NULL;
2750
2751     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2752
2753     while (SvAMAGIC(ref) &&
2754            (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2755                                 AMGf_noright | AMGf_unary))) {
2756         if (!SvROK(tmpsv))
2757             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2758         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2759             /* Bail out if it returns us the same reference.  */
2760             return tmpsv;
2761         }
2762         ref = tmpsv;
2763     }
2764     return tmpsv ? tmpsv : ref;
2765 }
2766
2767 bool
2768 Perl_amagic_is_enabled(pTHX_ int method)
2769 {
2770       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2771
2772       assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2773
2774       if ( !lex_mask || !SvOK(lex_mask) )
2775           /* overloading lexically disabled */
2776           return FALSE;
2777       else if ( lex_mask && SvPOK(lex_mask) ) {
2778           /* we have an entry in the hints hash, check if method has been
2779            * masked by overloading.pm */
2780           STRLEN len;
2781           const int offset = method / 8;
2782           const int bit    = method % 8;
2783           char *pv = SvPV(lex_mask, len);
2784
2785           /* Bit set, so this overloading operator is disabled */
2786           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2787               return FALSE;
2788       }
2789       return TRUE;
2790 }
2791
2792 SV*
2793 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2794 {
2795   dVAR;
2796   MAGIC *mg;
2797   CV *cv=NULL;
2798   CV **cvp=NULL, **ocvp=NULL;
2799   AMT *amtp=NULL, *oamtp=NULL;
2800   int off = 0, off1, lr = 0, notfound = 0;
2801   int postpr = 0, force_cpy = 0;
2802   int assign = AMGf_assign & flags;
2803   const int assignshift = assign ? 1 : 0;
2804   int use_default_op = 0;
2805   int force_scalar = 0;
2806 #ifdef DEBUGGING
2807   int fl=0;
2808 #endif
2809   HV* stash=NULL;
2810
2811   PERL_ARGS_ASSERT_AMAGIC_CALL;
2812
2813   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2814       if (!amagic_is_enabled(method)) return NULL;
2815   }
2816
2817   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2818       && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
2819       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2820       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2821                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2822                         : NULL))
2823       && ((cv = cvp[off=method+assignshift])
2824           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2825                                                           * usual method */
2826                   (
2827 #ifdef DEBUGGING
2828                    fl = 1,
2829 #endif
2830                    cv = cvp[off=method])))) {
2831     lr = -1;                    /* Call method for left argument */
2832   } else {
2833     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2834       int logic;
2835
2836       /* look for substituted methods */
2837       /* In all the covered cases we should be called with assign==0. */
2838          switch (method) {
2839          case inc_amg:
2840            force_cpy = 1;
2841            if ((cv = cvp[off=add_ass_amg])
2842                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2843              right = &PL_sv_yes; lr = -1; assign = 1;
2844            }
2845            break;
2846          case dec_amg:
2847            force_cpy = 1;
2848            if ((cv = cvp[off = subtr_ass_amg])
2849                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2850              right = &PL_sv_yes; lr = -1; assign = 1;
2851            }
2852            break;
2853          case bool__amg:
2854            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2855            break;
2856          case numer_amg:
2857            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2858            break;
2859          case string_amg:
2860            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2861            break;
2862          case not_amg:
2863            (void)((cv = cvp[off=bool__amg])
2864                   || (cv = cvp[off=numer_amg])
2865                   || (cv = cvp[off=string_amg]));
2866            if (cv)
2867                postpr = 1;
2868            break;
2869          case copy_amg:
2870            {
2871              /*
2872                   * SV* ref causes confusion with the interpreter variable of
2873                   * the same name
2874                   */
2875              SV* const tmpRef=SvRV(left);
2876              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2877                 /*
2878                  * Just to be extra cautious.  Maybe in some
2879                  * additional cases sv_setsv is safe, too.
2880                  */
2881                 SV* const newref = newSVsv(tmpRef);
2882                 SvOBJECT_on(newref);
2883                 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2884                    delegate to the stash. */
2885                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2886                 return newref;
2887              }
2888            }
2889            break;
2890          case abs_amg:
2891            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2892                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2893              SV* const nullsv=sv_2mortal(newSViv(0));
2894              if (off1==lt_amg) {
2895                SV* const lessp = amagic_call(left,nullsv,
2896                                        lt_amg,AMGf_noright);
2897                logic = SvTRUE(lessp);
2898              } else {
2899                SV* const lessp = amagic_call(left,nullsv,
2900                                        ncmp_amg,AMGf_noright);
2901                logic = (SvNV(lessp) < 0);
2902              }
2903              if (logic) {
2904                if (off==subtr_amg) {
2905                  right = left;
2906                  left = nullsv;
2907                  lr = 1;
2908                }
2909              } else {
2910                return left;
2911              }
2912            }
2913            break;
2914          case neg_amg:
2915            if ((cv = cvp[off=subtr_amg])) {
2916              right = left;
2917              left = sv_2mortal(newSViv(0));
2918              lr = 1;
2919            }
2920            break;
2921          case int_amg:
2922          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2923          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2924          case regexp_amg:
2925              /* FAIL safe */
2926              return NULL;       /* Delegate operation to standard mechanisms. */
2927              break;
2928          case to_sv_amg:
2929          case to_av_amg:
2930          case to_hv_amg:
2931          case to_gv_amg:
2932          case to_cv_amg:
2933              /* FAIL safe */
2934              return left;       /* Delegate operation to standard mechanisms. */
2935              break;
2936          default:
2937            goto not_found;
2938          }
2939          if (!cv) goto not_found;
2940     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2941                && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
2942                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2943                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2944                           ? (amtp = (AMT*)mg->mg_ptr)->table
2945                           : NULL))
2946                && (cv = cvp[off=method])) { /* Method for right
2947                                              * argument found */
2948       lr=1;
2949     } else if (((cvp && amtp->fallback > AMGfallNEVER)
2950                 || (ocvp && oamtp->fallback > AMGfallNEVER))
2951                && !(flags & AMGf_unary)) {
2952                                 /* We look for substitution for
2953                                  * comparison operations and
2954                                  * concatenation */
2955       if (method==concat_amg || method==concat_ass_amg
2956           || method==repeat_amg || method==repeat_ass_amg) {
2957         return NULL;            /* Delegate operation to string conversion */
2958       }
2959       off = -1;
2960       switch (method) {
2961          case lt_amg:
2962          case le_amg:
2963          case gt_amg:
2964          case ge_amg:
2965          case eq_amg:
2966          case ne_amg:
2967              off = ncmp_amg;
2968              break;
2969          case slt_amg:
2970          case sle_amg:
2971          case sgt_amg:
2972          case sge_amg:
2973          case seq_amg:
2974          case sne_amg:
2975              off = scmp_amg;
2976              break;
2977          }
2978       if (off != -1) {
2979           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2980               cv = ocvp[off];
2981               lr = -1;
2982           }
2983           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2984               cv = cvp[off];
2985               lr = 1;
2986           }
2987       }
2988       if (cv)
2989           postpr = 1;
2990       else
2991           goto not_found;
2992     } else {
2993     not_found:                  /* No method found, either report or croak */
2994       switch (method) {
2995          case to_sv_amg:
2996          case to_av_amg:
2997          case to_hv_amg:
2998          case to_gv_amg:
2999          case to_cv_amg:
3000              /* FAIL safe */
3001              return left;       /* Delegate operation to standard mechanisms. */
3002              break;
3003       }
3004       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3005         notfound = 1; lr = -1;
3006       } else if (cvp && (cv=cvp[nomethod_amg])) {
3007         notfound = 1; lr = 1;
3008       } else if ((use_default_op =
3009                   (!ocvp || oamtp->fallback >= AMGfallYES)
3010                   && (!cvp || amtp->fallback >= AMGfallYES))
3011                  && !DEBUG_o_TEST) {
3012         /* Skip generating the "no method found" message.  */
3013         return NULL;
3014       } else {
3015         SV *msg;
3016         if (off==-1) off=method;
3017         msg = sv_2mortal(Perl_newSVpvf(aTHX_
3018                       "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
3019                       AMG_id2name(method + assignshift),
3020                       (flags & AMGf_unary ? " " : "\n\tleft "),
3021                       SvAMAGIC(left)?
3022                         "in overloaded package ":
3023                         "has no overloaded magic",
3024                       SvAMAGIC(left)?
3025                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3026                         SVfARG(&PL_sv_no),
3027                       SvAMAGIC(right)?
3028                         ",\n\tright argument in overloaded package ":
3029                         (flags & AMGf_unary
3030                          ? ""
3031                          : ",\n\tright argument has no overloaded magic"),
3032                       SvAMAGIC(right)?
3033                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3034                         SVfARG(&PL_sv_no)));
3035         if (use_default_op) {
3036           DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
3037         } else {
3038           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
3039         }
3040         return NULL;
3041       }
3042       force_cpy = force_cpy || assign;
3043     }
3044   }
3045
3046   switch (method) {
3047     /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3048      * operation. we need this to return a value, so that it can be assigned
3049      * later on, in the postpr block (case inc_amg/dec_amg), even if the
3050      * increment or decrement was itself called in void context */
3051     case inc_amg:
3052       if (off == add_amg)
3053         force_scalar = 1;
3054       break;
3055     case dec_amg:
3056       if (off == subtr_amg)
3057         force_scalar = 1;
3058       break;
3059     /* in these cases, we're calling an assignment variant of an operator
3060      * (+= rather than +, for instance). regardless of whether it's a
3061      * fallback or not, it always has to return a value, which will be
3062      * assigned to the proper variable later */
3063     case add_amg:
3064     case subtr_amg:
3065     case mult_amg:
3066     case div_amg:
3067     case modulo_amg:
3068     case pow_amg:
3069     case lshift_amg:
3070     case rshift_amg:
3071     case repeat_amg:
3072     case concat_amg:
3073     case band_amg:
3074     case bor_amg:
3075     case bxor_amg:
3076       if (assign)
3077         force_scalar = 1;
3078       break;
3079     /* the copy constructor always needs to return a value */
3080     case copy_amg:
3081       force_scalar = 1;
3082       break;
3083     /* because of the way these are implemented (they don't perform the
3084      * dereferencing themselves, they return a reference that perl then
3085      * dereferences later), they always have to be in scalar context */
3086     case to_sv_amg:
3087     case to_av_amg:
3088     case to_hv_amg:
3089     case to_gv_amg:
3090     case to_cv_amg:
3091       force_scalar = 1;
3092       break;
3093     /* these don't have an op of their own; they're triggered by their parent
3094      * op, so the context there isn't meaningful ('$a and foo()' in void
3095      * context still needs to pass scalar context on to $a's bool overload) */
3096     case bool__amg:
3097     case numer_amg:
3098     case string_amg:
3099       force_scalar = 1;
3100       break;
3101   }
3102
3103 #ifdef DEBUGGING
3104   if (!notfound) {
3105     DEBUG_o(Perl_deb(aTHX_
3106                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
3107                      AMG_id2name(off),
3108                      method+assignshift==off? "" :
3109                      " (initially \"",
3110                      method+assignshift==off? "" :
3111                      AMG_id2name(method+assignshift),
3112                      method+assignshift==off? "" : "\")",
3113                      flags & AMGf_unary? "" :
3114                      lr==1 ? " for right argument": " for left argument",
3115                      flags & AMGf_unary? " for argument" : "",
3116                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3117                      fl? ",\n\tassignment variant used": "") );
3118   }
3119 #endif
3120     /* Since we use shallow copy during assignment, we need
3121      * to dublicate the contents, probably calling user-supplied
3122      * version of copy operator
3123      */
3124     /* We need to copy in following cases:
3125      * a) Assignment form was called.
3126      *          assignshift==1,  assign==T, method + 1 == off
3127      * b) Increment or decrement, called directly.
3128      *          assignshift==0,  assign==0, method + 0 == off
3129      * c) Increment or decrement, translated to assignment add/subtr.
3130      *          assignshift==0,  assign==T,
3131      *          force_cpy == T
3132      * d) Increment or decrement, translated to nomethod.
3133      *          assignshift==0,  assign==0,
3134      *          force_cpy == T
3135      * e) Assignment form translated to nomethod.
3136      *          assignshift==1,  assign==T, method + 1 != off
3137      *          force_cpy == T
3138      */
3139     /*  off is method, method+assignshift, or a result of opcode substitution.
3140      *  In the latter case assignshift==0, so only notfound case is important.
3141      */
3142   if ( (lr == -1) && ( ( (method + assignshift == off)
3143         && (assign || (method == inc_amg) || (method == dec_amg)))
3144       || force_cpy) )
3145   {
3146       /* newSVsv does not behave as advertised, so we copy missing
3147        * information by hand */
3148       SV *tmpRef = SvRV(left);
3149       SV *rv_copy;
3150       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3151           SvRV_set(left, rv_copy);
3152           SvSETMAGIC(left);
3153           SvREFCNT_dec_NN(tmpRef);
3154       }
3155   }
3156
3157   {
3158     dSP;
3159     BINOP myop;
3160     SV* res;
3161     const bool oldcatch = CATCH_GET;
3162     I32 oldmark, nret;
3163     int gimme = force_scalar ? G_SCALAR : GIMME_V;
3164
3165     CATCH_SET(TRUE);
3166     Zero(&myop, 1, BINOP);
3167     myop.op_last = (OP *) &myop;
3168     myop.op_next = NULL;
3169     myop.op_flags = OPf_STACKED;
3170
3171     switch (gimme) {
3172         case G_VOID:
3173             myop.op_flags |= OPf_WANT_VOID;
3174             break;
3175         case G_ARRAY:
3176             if (flags & AMGf_want_list) {
3177                 myop.op_flags |= OPf_WANT_LIST;
3178                 break;
3179             }
3180             /* FALLTHROUGH */
3181         default:
3182             myop.op_flags |= OPf_WANT_SCALAR;
3183             break;
3184     }
3185
3186     PUSHSTACKi(PERLSI_OVERLOAD);
3187     ENTER;
3188     SAVEOP();
3189     PL_op = (OP *) &myop;
3190     if (PERLDB_SUB && PL_curstash != PL_debstash)
3191         PL_op->op_private |= OPpENTERSUB_DB;
3192     Perl_pp_pushmark(aTHX);
3193
3194     EXTEND(SP, notfound + 5);
3195     PUSHs(lr>0? right: left);
3196     PUSHs(lr>0? left: right);
3197     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3198     if (notfound) {
3199       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3200                            AMG_id2namelen(method + assignshift), SVs_TEMP));
3201     }
3202     PUSHs(MUTABLE_SV(cv));
3203     PUTBACK;
3204     oldmark = TOPMARK;
3205
3206     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3207       CALLRUNOPS(aTHX);
3208     LEAVE;
3209     SPAGAIN;
3210     nret = SP - (PL_stack_base + oldmark);
3211
3212     switch (gimme) {
3213         case G_VOID:
3214             /* returning NULL has another meaning, and we check the context
3215              * at the call site too, so this can be differentiated from the
3216              * scalar case */
3217             res = &PL_sv_undef;
3218             SP = PL_stack_base + oldmark;
3219             break;
3220         case G_ARRAY: {
3221             if (flags & AMGf_want_list) {
3222                 res = sv_2mortal((SV *)newAV());
3223                 av_extend((AV *)res, nret);
3224                 while (nret--)
3225                     av_store((AV *)res, nret, POPs);
3226                 break;
3227             }
3228             /* FALLTHROUGH */
3229         }
3230         default:
3231             res = POPs;
3232             break;
3233     }
3234
3235     PUTBACK;
3236     POPSTACK;
3237     CATCH_SET(oldcatch);
3238
3239     if (postpr) {
3240       int ans;
3241       switch (method) {
3242       case le_amg:
3243       case sle_amg:
3244         ans=SvIV(res)<=0; break;
3245       case lt_amg:
3246       case slt_amg:
3247         ans=SvIV(res)<0; break;
3248       case ge_amg:
3249       case sge_amg:
3250         ans=SvIV(res)>=0; break;
3251       case gt_amg:
3252       case sgt_amg:
3253         ans=SvIV(res)>0; break;
3254       case eq_amg:
3255       case seq_amg:
3256         ans=SvIV(res)==0; break;
3257       case ne_amg:
3258       case sne_amg:
3259         ans=SvIV(res)!=0; break;
3260       case inc_amg:
3261       case dec_amg:
3262         SvSetSV(left,res); return left;
3263       case not_amg:
3264         ans=!SvTRUE(res); break;
3265       default:
3266         ans=0; break;
3267       }
3268       return boolSV(ans);
3269     } else if (method==copy_amg) {
3270       if (!SvROK(res)) {
3271         Perl_croak(aTHX_ "Copy method did not return a reference");
3272       }
3273       return SvREFCNT_inc(SvRV(res));
3274     } else {
3275       return res;
3276     }
3277   }
3278 }
3279
3280 void
3281 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3282 {
3283     dVAR;
3284     U32 hash;
3285
3286     PERL_ARGS_ASSERT_GV_NAME_SET;
3287
3288     if (len > I32_MAX)
3289         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3290
3291     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3292         unshare_hek(GvNAME_HEK(gv));
3293     }
3294
3295     PERL_HASH(hash, name, len);
3296     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3297 }
3298
3299 /*
3300 =for apidoc gv_try_downgrade
3301
3302 If the typeglob C<gv> can be expressed more succinctly, by having
3303 something other than a real GV in its place in the stash, replace it
3304 with the optimised form.  Basic requirements for this are that C<gv>
3305 is a real typeglob, is sufficiently ordinary, and is only referenced
3306 from its package.  This function is meant to be used when a GV has been
3307 looked up in part to see what was there, causing upgrading, but based
3308 on what was found it turns out that the real GV isn't required after all.
3309
3310 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3311
3312 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3313 sub, the typeglob is replaced with a scalar-reference placeholder that
3314 more compactly represents the same thing.
3315
3316 =cut
3317 */
3318
3319 void
3320 Perl_gv_try_downgrade(pTHX_ GV *gv)
3321 {
3322     HV *stash;
3323     CV *cv;
3324     HEK *namehek;
3325     SV **gvp;
3326     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3327
3328     /* XXX Why and where does this leave dangling pointers during global
3329        destruction? */
3330     if (PL_phase == PERL_PHASE_DESTRUCT) return;
3331
3332     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3333             !SvOBJECT(gv) && !SvREADONLY(gv) &&
3334             isGV_with_GP(gv) && GvGP(gv) &&
3335             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3336             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3337             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3338         return;
3339     if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3340         return;
3341     if (SvMAGICAL(gv)) {
3342         MAGIC *mg;
3343         /* only backref magic is allowed */
3344         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3345             return;
3346         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3347             if (mg->mg_type != PERL_MAGIC_backref)
3348                 return;
3349         }
3350     }
3351     cv = GvCV(gv);
3352     if (!cv) {
3353         HEK *gvnhek = GvNAME_HEK(gv);
3354         (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3355     } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3356             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3357             CvSTASH(cv) == stash && CvGV(cv) == gv &&
3358             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3359             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3360             (namehek = GvNAME_HEK(gv)) &&
3361             (gvp = hv_fetchhek(stash, namehek, 0)) &&
3362             *gvp == (SV*)gv) {
3363         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3364         const bool imported = !!GvIMPORTED_CV(gv);
3365         SvREFCNT(gv) = 0;
3366         sv_clear((SV*)gv);
3367         SvREFCNT(gv) = 1;
3368         SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3369         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3370                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3371         SvRV_set(gv, value);
3372     }
3373 }
3374
3375 GV *
3376 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3377 {
3378     GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3379     GV * const *gvp;
3380     PERL_ARGS_ASSERT_GV_OVERRIDE;
3381     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3382     gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3383     gv = gvp ? *gvp : NULL;
3384     if (gv && !isGV(gv)) {
3385         if (!SvPCS_IMPORTED(gv)) return NULL;
3386         gv_init(gv, PL_globalstash, name, len, 0);
3387         return gv;
3388     }
3389     return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3390 }
3391
3392 #include "XSUB.h"
3393
3394 static void
3395 core_xsub(pTHX_ CV* cv)
3396 {
3397     Perl_croak(aTHX_
3398        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3399     );
3400 }
3401
3402 /*
3403  * Local variables:
3404  * c-indentation-style: bsd
3405  * c-basic-offset: 4
3406  * indent-tabs-mode: nil
3407  * End:
3408  *
3409  * ex: set ts=8 sts=4 sw=4 et:
3410  */