gv.c

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