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