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