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