gv.c

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