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 HV*
1317 Perl_gv_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 /*
1355 =for apidoc gv_stashsv
1356
1357 Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
1358
1359 =cut
1360 */
1361
1362 HV*
1363 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1364 {
1365     STRLEN len;
1366     const char * const ptr = SvPV_const(sv,len);
1367
1368     PERL_ARGS_ASSERT_GV_STASHSV;
1369
1370     return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
1371 }
1372
1373
1374 GV *
1375 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1376     PERL_ARGS_ASSERT_GV_FETCHPV;
1377     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1378 }
1379
1380 GV *
1381 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1382     STRLEN len;
1383     const char * const nambeg =
1384        SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1385     PERL_ARGS_ASSERT_GV_FETCHSV;
1386     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1387 }
1388
1389 PERL_STATIC_INLINE void
1390 S_gv_magicalize_isa(pTHX_ GV *gv)
1391 {
1392     AV* av;
1393
1394     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1395
1396     av = GvAVn(gv);
1397     GvMULTI_on(gv);
1398     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1399              NULL, 0);
1400 }
1401
1402 /* This function grabs name and tries to split a stash and glob
1403  * from its contents. TODO better description, comments
1404  *
1405  * If the function returns TRUE and 'name == name_end', then
1406  * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1407  */
1408 PERL_STATIC_INLINE bool
1409 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1410                STRLEN *len, const char *nambeg, STRLEN full_len,
1411                const U32 is_utf8, const I32 add)
1412 {
1413     const char *name_cursor;
1414     const char *const name_end = nambeg + full_len;
1415     const char *const name_em1 = name_end - 1;
1416
1417     PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1418
1419     if (full_len > 2 && **name == '*' && isIDFIRST_lazy_if(*name + 1, is_utf8)) {
1420         /* accidental stringify on a GV? */
1421         (*name)++;
1422     }
1423
1424     for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1425         if (name_cursor < name_em1 &&
1426             ((*name_cursor == ':' && name_cursor[1] == ':')
1427            || *name_cursor == '\''))
1428         {
1429             if (!*stash)
1430                 *stash = PL_defstash;
1431             if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1432                 return FALSE;
1433
1434             *len = name_cursor - *name;
1435             if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1436                 const char *key;
1437                 GV**gvp;
1438                 if (*name_cursor == ':') {
1439                     key = *name;
1440                     *len += 2;
1441                 }
1442                 else {
1443                     char *tmpbuf;
1444                     Newx(tmpbuf, *len+2, char);
1445                     Copy(*name, tmpbuf, *len, char);
1446                     tmpbuf[(*len)++] = ':';
1447                     tmpbuf[(*len)++] = ':';
1448                     key = tmpbuf;
1449                 }
1450                 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1451                 *gv = gvp ? *gvp : NULL;
1452                 if (*gv && *gv != (const GV *)&PL_sv_undef) {
1453                     if (SvTYPE(*gv) != SVt_PVGV)
1454                         gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1455                     else
1456                         GvMULTI_on(*gv);
1457                 }
1458                 if (key != *name)
1459                     Safefree(key);
1460                 if (!*gv || *gv == (const GV *)&PL_sv_undef)
1461                     return FALSE;
1462
1463                 if (!(*stash = GvHV(*gv))) {
1464                     *stash = GvHV(*gv) = newHV();
1465                     if (!HvNAME_get(*stash)) {
1466                         if (GvSTASH(*gv) == PL_defstash && *len == 6
1467                             && strnEQ(*name, "CORE", 4))
1468                             hv_name_set(*stash, "CORE", 4, 0);
1469                         else
1470                             hv_name_set(
1471                                 *stash, nambeg, name_cursor-nambeg, is_utf8
1472                             );
1473                     /* If the containing stash has multiple effective
1474                     names, see that this one gets them, too. */
1475                     if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1476                         mro_package_moved(*stash, NULL, *gv, 1);
1477                     }
1478                 }
1479                 else if (!HvNAME_get(*stash))
1480                     hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1481             }
1482
1483             if (*name_cursor == ':')
1484                 name_cursor++;
1485             *name = name_cursor+1;
1486             if (*name == name_end) {
1487                 if (!*gv)
1488                     *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1489                 return TRUE;
1490             }
1491         }
1492     }
1493     *len = name_cursor - *name;
1494     return TRUE;
1495 }
1496
1497 /* Checks if an unqualified name is in the main stash */
1498 PERL_STATIC_INLINE bool
1499 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1500 {
1501     PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1502
1503     /* If it's an alphanumeric variable */
1504     if ( len && isIDFIRST_lazy_if(name, is_utf8) ) {
1505         /* Some "normal" variables are always in main::,
1506          * like INC or STDOUT.
1507          */
1508         switch (len) {
1509             case 1:
1510             if (*name == '_')
1511                 return TRUE;
1512             break;
1513             case 3:
1514             if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1515                 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1516                 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1517                 return TRUE;
1518             break;
1519             case 4:
1520             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1521                 && name[3] == 'V')
1522                 return TRUE;
1523             break;
1524             case 5:
1525             if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1526                 && name[3] == 'I' && name[4] == 'N')
1527                 return TRUE;
1528             break;
1529             case 6:
1530             if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1531                 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1532                     ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1533                 return TRUE;
1534             break;
1535             case 7:
1536             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1537                 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1538                 && name[6] == 'T')
1539                 return TRUE;
1540             break;
1541         }
1542     }
1543     /* *{""}, or a special variable like $@ */
1544     else
1545         return TRUE;
1546
1547     return FALSE;
1548 }
1549
1550
1551 /* This function is called if parse_gv_stash_name() failed to
1552  * find a stash, or if GV_NOTQUAL or an empty name was passed
1553  * to gv_fetchpvn_flags.
1554  *
1555  * It returns FALSE if the default stash can't be found nor created,
1556  * which might happen during global destruction.
1557  */
1558 PERL_STATIC_INLINE bool
1559 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1560                const U32 is_utf8, const I32 add,
1561                const svtype sv_type)
1562 {
1563     PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1564
1565     /* No stash in name, so see how we can default */
1566
1567     if ( gv_is_in_main(name, len, is_utf8) ) {
1568         *stash = PL_defstash;
1569     }
1570     else {
1571         if (IN_PERL_COMPILETIME) {
1572             *stash = PL_curstash;
1573             if (add && (PL_hints & HINT_STRICT_VARS) &&
1574                 sv_type != SVt_PVCV &&
1575                 sv_type != SVt_PVGV &&
1576                 sv_type != SVt_PVFM &&
1577                 sv_type != SVt_PVIO &&
1578                 !(len == 1 && sv_type == SVt_PV &&
1579                 (*name == 'a' || *name == 'b')) )
1580             {
1581                 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1582                 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1583                     SvTYPE(*gvp) != SVt_PVGV)
1584                 {
1585                     *stash = NULL;
1586                 }
1587                 else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1588                          (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1589                          (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1590                 {
1591                     /* diag_listed_as: Variable "%s" is not imported%s */
1592                     Perl_ck_warner_d(
1593                         aTHX_ packWARN(WARN_MISC),
1594                         "Variable \"%c%"UTF8f"\" is not imported",
1595                         sv_type == SVt_PVAV ? '@' :
1596                         sv_type == SVt_PVHV ? '%' : '$',
1597                         UTF8fARG(is_utf8, len, name));
1598                     if (GvCVu(*gvp))
1599                         Perl_ck_warner_d(
1600                             aTHX_ packWARN(WARN_MISC),
1601                             "\t(Did you mean &%"UTF8f" instead?)\n",
1602                             UTF8fARG(is_utf8, len, name)
1603                         );
1604                     *stash = NULL;
1605                 }
1606             }
1607         }
1608         else {
1609             /* Use the current op's stash */
1610             *stash = CopSTASH(PL_curcop);
1611         }
1612     }
1613
1614     if (!*stash) {
1615         if (add && !PL_in_clean_all) {
1616             SV * const err = Perl_mess(aTHX_
1617                  "Global symbol \"%s%"UTF8f
1618                  "\" requires explicit package name",
1619                  (sv_type == SVt_PV ? "$"
1620                   : sv_type == SVt_PVAV ? "@"
1621                   : sv_type == SVt_PVHV ? "%"
1622                   : ""), UTF8fARG(is_utf8, len, name));
1623             GV *gv;
1624             if (is_utf8)
1625                 SvUTF8_on(err);
1626             qerror(err);
1627             /* To maintain the output of errors after the strict exception
1628              * above, and to keep compat with older releases, rather than
1629              * placing the variables in the pad, we place
1630              * them in the <none>:: stash.
1631              */
1632             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1633             if (!gv) {
1634                 /* symbol table under destruction */
1635                 return FALSE;
1636             }
1637             *stash = GvHV(gv);
1638         }
1639         else
1640             return FALSE;
1641     }
1642
1643     if (!SvREFCNT(*stash))   /* symbol table under destruction */
1644         return FALSE;
1645
1646     return TRUE;
1647 }
1648
1649 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1650  * a new GV.
1651  * Note that it does not insert the GV into the stash prior to
1652  * magicalization, which some variables require need in order
1653  * to work (like $[, %+, %-, %!), so callers must take care of
1654  * that beforehand.
1655  *
1656  * The return value has a specific meaning for gv_fetchpvn_flags:
1657  * If it returns true, and the gv is empty, it indicates that its
1658  * refcount should be decreased.
1659  */
1660 PERL_STATIC_INLINE bool
1661 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1662                bool addmg, const svtype sv_type)
1663 {
1664     SSize_t paren;
1665
1666     PERL_ARGS_ASSERT_GV_MAGICALIZE;
1667
1668     if (stash != PL_defstash) { /* not the main stash */
1669         /* We only have to check for a few names here: a, b, EXPORT, ISA
1670            and VERSION. All the others apply only to the main stash or to
1671            CORE (which is checked right after this). */
1672         if (len) {
1673             const char * const name2 = name + 1;
1674             switch (*name) {
1675             case 'E':
1676                 if (strnEQ(name2, "XPORT", 5))
1677                     GvMULTI_on(gv);
1678                 break;
1679             case 'I':
1680                 if (strEQ(name2, "SA"))
1681                     gv_magicalize_isa(gv);
1682                 break;
1683             case 'V':
1684                 if (strEQ(name2, "ERSION"))
1685                     GvMULTI_on(gv);
1686                 break;
1687             case 'a':
1688             case 'b':
1689                 if (len == 1 && sv_type == SVt_PV)
1690                     GvMULTI_on(gv);
1691                 /* FALLTHROUGH */
1692             default:
1693                 goto try_core;
1694             }
1695             return addmg;
1696         }
1697       try_core:
1698         if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1699           /* Avoid null warning: */
1700           const char * const stashname = HvNAME(stash); assert(stashname);
1701           if (strnEQ(stashname, "CORE", 4))
1702             S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1703         }
1704     }
1705     else if (len > 1) {
1706 #ifndef EBCDIC
1707         if (*name > 'V' ) {
1708             NOOP;
1709             /* Nothing else to do.
1710                The compiler will probably turn the switch statement into a
1711                branch table. Make sure we avoid even that small overhead for
1712                the common case of lower case variable names.  (On EBCDIC
1713                platforms, we can't just do:
1714                  if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1715                because cases like '\027' in the switch statement below are
1716                C1 (non-ASCII) controls on those platforms, so the remapping
1717                would make them larger than 'V')
1718              */
1719         } else
1720 #endif
1721         {
1722             const char * const name2 = name + 1;
1723             switch (*name) {
1724             case 'A':
1725                 if (strEQ(name2, "RGV")) {
1726                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1727                 }
1728                 else if (strEQ(name2, "RGVOUT")) {
1729                     GvMULTI_on(gv);
1730                 }
1731                 break;
1732             case 'E':
1733                 if (strnEQ(name2, "XPORT", 5))
1734                     GvMULTI_on(gv);
1735                 break;
1736             case 'I':
1737                 if (strEQ(name2, "SA")) {
1738                     gv_magicalize_isa(gv);
1739                 }
1740                 break;
1741             case 'S':
1742                 if (strEQ(name2, "IG")) {
1743                     HV *hv;
1744                     I32 i;
1745                     if (!PL_psig_name) {
1746                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1747                         Newxz(PL_psig_pend, SIG_SIZE, int);
1748                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1749                     } else {
1750                         /* I think that the only way to get here is to re-use an
1751                            embedded perl interpreter, where the previous
1752                            use didn't clean up fully because
1753                            PL_perl_destruct_level was 0. I'm not sure that we
1754                            "support" that, in that I suspect in that scenario
1755                            there are sufficient other garbage values left in the
1756                            interpreter structure that something else will crash
1757                            before we get here. I suspect that this is one of
1758                            those "doctor, it hurts when I do this" bugs.  */
1759                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1760                         Zero(PL_psig_pend, SIG_SIZE, int);
1761                     }
1762                     GvMULTI_on(gv);
1763                     hv = GvHVn(gv);
1764                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1765                     for (i = 1; i < SIG_SIZE; i++) {
1766                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1767                         if (init)
1768                             sv_setsv(*init, &PL_sv_undef);
1769                     }
1770                 }
1771                 break;
1772             case 'V':
1773                 if (strEQ(name2, "ERSION"))
1774                     GvMULTI_on(gv);
1775                 break;
1776             case '\003':        /* $^CHILD_ERROR_NATIVE */
1777                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1778                     goto magicalize;
1779                 break;
1780             case '\005':        /* $^ENCODING */
1781                 if (strEQ(name2, "NCODING"))
1782                     goto magicalize;
1783                 break;
1784             case '\007':        /* $^GLOBAL_PHASE */
1785                 if (strEQ(name2, "LOBAL_PHASE"))
1786                     goto ro_magicalize;
1787                 break;
1788             case '\014':        /* $^LAST_FH */
1789                 if (strEQ(name2, "AST_FH"))
1790                     goto ro_magicalize;
1791                 break;
1792             case '\015':        /* $^MATCH */
1793                 if (strEQ(name2, "ATCH")) {
1794                     paren = RX_BUFF_IDX_CARET_FULLMATCH;
1795                     goto storeparen;
1796                 }
1797                 break;
1798             case '\017':        /* $^OPEN */
1799                 if (strEQ(name2, "PEN"))
1800                     goto magicalize;
1801                 break;
1802             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1803                 if (strEQ(name2, "REMATCH")) {
1804                     paren = RX_BUFF_IDX_CARET_PREMATCH;
1805                     goto storeparen;
1806                 }
1807                 if (strEQ(name2, "OSTMATCH")) {
1808                     paren = RX_BUFF_IDX_CARET_POSTMATCH;
1809                     goto storeparen;
1810                 }
1811                 break;
1812             case '\024':        /* ${^TAINT} */
1813                 if (strEQ(name2, "AINT"))
1814                     goto ro_magicalize;
1815                 break;
1816             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1817                 if (strEQ(name2, "NICODE"))
1818                     goto ro_magicalize;
1819                 if (strEQ(name2, "TF8LOCALE"))
1820                     goto ro_magicalize;
1821                 if (strEQ(name2, "TF8CACHE"))
1822                     goto magicalize;
1823                 break;
1824             case '\027':        /* $^WARNING_BITS */
1825                 if (strEQ(name2, "ARNING_BITS"))
1826                     goto magicalize;
1827                 break;
1828             case '1':
1829             case '2':
1830             case '3':
1831             case '4':
1832             case '5':
1833             case '6':
1834             case '7':
1835             case '8':
1836             case '9':
1837             {
1838                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1839                    this test  */
1840                 /* This snippet is taken from is_gv_magical */
1841                 const char *end = name + len;
1842                 while (--end > name) {
1843                     if (!isDIGIT(*end))
1844                         return addmg;
1845                 }
1846                 paren = grok_atou(name, NULL);
1847                 goto storeparen;
1848             }
1849             }
1850         }
1851     } else {
1852         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1853            be case '\0' in this switch statement (ie a default case)  */
1854         switch (*name) {
1855         case '&':               /* $& */
1856             paren = RX_BUFF_IDX_FULLMATCH;
1857             goto sawampersand;
1858         case '`':               /* $` */
1859             paren = RX_BUFF_IDX_PREMATCH;
1860             goto sawampersand;
1861         case '\'':              /* $' */
1862             paren = RX_BUFF_IDX_POSTMATCH;
1863         sawampersand:
1864 #ifdef PERL_SAWAMPERSAND
1865             if (!(
1866                 sv_type == SVt_PVAV ||
1867                 sv_type == SVt_PVHV ||
1868                 sv_type == SVt_PVCV ||
1869                 sv_type == SVt_PVFM ||
1870                 sv_type == SVt_PVIO
1871                 )) { PL_sawampersand |=
1872                         (*name == '`')
1873                             ? SAWAMPERSAND_LEFT
1874                             : (*name == '&')
1875                                 ? SAWAMPERSAND_MIDDLE
1876                                 : SAWAMPERSAND_RIGHT;
1877                 }
1878 #endif
1879             goto storeparen;
1880         case '1':               /* $1 */
1881         case '2':               /* $2 */
1882         case '3':               /* $3 */
1883         case '4':               /* $4 */
1884         case '5':               /* $5 */
1885         case '6':               /* $6 */
1886         case '7':               /* $7 */
1887         case '8':               /* $8 */
1888         case '9':               /* $9 */
1889             paren = *name - '0';
1890
1891         storeparen:
1892             /* Flag the capture variables with a NULL mg_ptr
1893                Use mg_len for the array index to lookup.  */
1894             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
1895             break;
1896
1897         case ':':               /* $: */
1898             sv_setpv(GvSVn(gv),PL_chopset);
1899             goto magicalize;
1900
1901         case '?':               /* $? */
1902 #ifdef COMPLEX_STATUS
1903             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1904 #endif
1905             goto magicalize;
1906
1907         case '!':               /* $! */
1908             GvMULTI_on(gv);
1909             /* If %! has been used, automatically load Errno.pm. */
1910
1911             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1912
1913             /* magicalization must be done before require_tie_mod is called */
1914             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1915             {
1916                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1917                 addmg = FALSE;
1918             }
1919
1920             break;
1921         case '-':               /* $- */
1922         case '+':               /* $+ */
1923         GvMULTI_on(gv); /* no used once warnings here */
1924         {
1925             AV* const av = GvAVn(gv);
1926             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1927
1928             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1929             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1930             if (avc)
1931                 SvREADONLY_on(GvSVn(gv));
1932             SvREADONLY_on(av);
1933
1934             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1935             {
1936                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1937                 addmg = FALSE;
1938             }
1939
1940             break;
1941         }
1942         case '*':               /* $* */
1943         case '#':               /* $# */
1944             if (sv_type == SVt_PV)
1945                 /* diag_listed_as: $* is no longer supported */
1946                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1947                                  "$%c is no longer supported", *name);
1948             break;
1949         case '\010':    /* $^H */
1950             {
1951                 HV *const hv = GvHVn(gv);
1952                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1953             }
1954             goto magicalize;
1955         case '[':               /* $[ */
1956             if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
1957              && FEATURE_ARYBASE_IS_ENABLED) {
1958                 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1959                 addmg = FALSE;
1960             }
1961             else goto magicalize;
1962             break;
1963         case '\023':    /* $^S */
1964         ro_magicalize:
1965             SvREADONLY_on(GvSVn(gv));
1966             /* FALLTHROUGH */
1967         case '0':               /* $0 */
1968         case '^':               /* $^ */
1969         case '~':               /* $~ */
1970         case '=':               /* $= */
1971         case '%':               /* $% */
1972         case '.':               /* $. */
1973         case '(':               /* $( */
1974         case ')':               /* $) */
1975         case '<':               /* $< */
1976         case '>':               /* $> */
1977         case '\\':              /* $\ */
1978         case '/':               /* $/ */
1979         case '|':               /* $| */
1980         case '$':               /* $$ */
1981         case '\001':    /* $^A */
1982         case '\003':    /* $^C */
1983         case '\004':    /* $^D */
1984         case '\005':    /* $^E */
1985         case '\006':    /* $^F */
1986         case '\011':    /* $^I, NOT \t in EBCDIC */
1987         case '\016':    /* $^N */
1988         case '\017':    /* $^O */
1989         case '\020':    /* $^P */
1990         case '\024':    /* $^T */
1991         case '\027':    /* $^W */
1992         magicalize:
1993             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1994             break;
1995
1996         case '\014':    /* $^L */
1997             sv_setpvs(GvSVn(gv),"\f");
1998             break;
1999         case ';':               /* $; */
2000             sv_setpvs(GvSVn(gv),"\034");
2001             break;
2002         case ']':               /* $] */
2003         {
2004             SV * const sv = GvSV(gv);
2005             if (!sv_derived_from(PL_patchlevel, "version"))
2006                 upg_version(PL_patchlevel, TRUE);
2007             GvSV(gv) = vnumify(PL_patchlevel);
2008             SvREADONLY_on(GvSV(gv));
2009             SvREFCNT_dec(sv);
2010         }
2011         break;
2012         case '\026':    /* $^V */
2013         {
2014             SV * const sv = GvSV(gv);
2015             GvSV(gv) = new_version(PL_patchlevel);
2016             SvREADONLY_on(GvSV(gv));
2017             SvREFCNT_dec(sv);
2018         }
2019         break;
2020         case 'a':
2021         case 'b':
2022             if (sv_type == SVt_PV)
2023                 GvMULTI_on(gv);
2024         }
2025     }
2026
2027     return addmg;
2028 }
2029
2030 /* This function is called when the stash already holds the GV of the magic
2031  * variable we're looking for, but we need to check that it has the correct
2032  * kind of magic.  For example, if someone first uses $! and then %!, the
2033  * latter would end up here, and we add the Errno tie to the HASH slot of
2034  * the *! glob.
2035  */
2036 PERL_STATIC_INLINE void
2037 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2038 {
2039     PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2040
2041     if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2042         if (*name == '!')
2043             require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
2044         else if (*name == '-' || *name == '+')
2045             require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
2046     } else if (sv_type == SVt_PV) {
2047         if (*name == '*' || *name == '#') {
2048             /* diag_listed_as: $* is no longer supported */
2049             Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
2050                                              WARN_SYNTAX),
2051                              "$%c is no longer supported", *name);
2052         }
2053     }
2054     if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2055       switch (*name) {
2056       case '[':
2057           require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
2058           break;
2059 #ifdef PERL_SAWAMPERSAND
2060       case '`':
2061           PL_sawampersand |= SAWAMPERSAND_LEFT;
2062           (void)GvSVn(gv);
2063           break;
2064       case '&':
2065           PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2066           (void)GvSVn(gv);
2067           break;
2068       case '\'':
2069           PL_sawampersand |= SAWAMPERSAND_RIGHT;
2070           (void)GvSVn(gv);
2071           break;
2072 #endif
2073       }
2074     }
2075 }
2076
2077 GV *
2078 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2079                        const svtype sv_type)
2080 {
2081     const char *name = nambeg;
2082     GV *gv = NULL;
2083     GV**gvp;
2084     STRLEN len;
2085     HV *stash = NULL;
2086     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2087     const I32 no_expand = flags & GV_NOEXPAND;
2088     const I32 add = flags & ~GV_NOADD_MASK;
2089     const U32 is_utf8 = flags & SVf_UTF8;
2090     bool addmg = cBOOL(flags & GV_ADDMG);
2091     const char *const name_end = nambeg + full_len;
2092     U32 faking_it;
2093
2094     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2095
2096      /* If we have GV_NOTQUAL, the caller promised that
2097       * there is no stash, so we can skip the check.
2098       * Similarly if full_len is 0, since then we're
2099       * dealing with something like *{""} or ""->foo()
2100       */
2101     if ((flags & GV_NOTQUAL) || !full_len) {
2102         len = full_len;
2103     }
2104     else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2105         if (name == name_end) return gv;
2106     }
2107     else {
2108         return NULL;
2109     }
2110
2111     if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2112         return NULL;
2113     }
2114
2115     /* By this point we should have a stash and a name */
2116     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2117     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2118         if (addmg) gv = (GV *)newSV(0);
2119         else return NULL;
2120     }
2121     else gv = *gvp, addmg = 0;
2122     /* From this point on, addmg means gv has not been inserted in the
2123        symtab yet. */
2124
2125     if (SvTYPE(gv) == SVt_PVGV) {
2126         /* The GV already exists, so return it, but check if we need to do
2127          * anything else with it before that.
2128          */
2129         if (add) {
2130             /* This is the heuristic that handles if a variable triggers the
2131              * 'used only once' warning.  If there's already a GV in the stash
2132              * with this name, then we assume that the variable has been used
2133              * before and turn its MULTI flag on.
2134              * It's a heuristic because it can easily be "tricked", like with
2135              * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2136              * not warning about $main::foo being used just once
2137              */
2138             GvMULTI_on(gv);
2139             gv_init_svtype(gv, sv_type);
2140             /* You reach this path once the typeglob has already been created,
2141                either by the same or a different sigil.  If this path didn't
2142                exist, then (say) referencing $! first, and %! second would
2143                mean that %! was not handled correctly.  */
2144             if (len == 1 && stash == PL_defstash) {
2145                 maybe_multimagic_gv(gv, name, sv_type);
2146             }
2147             else if (len == 3 && sv_type == SVt_PVAV
2148                   && strnEQ(name, "ISA", 3)
2149                   && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2150                 gv_magicalize_isa(gv);
2151         }
2152         return gv;
2153     } else if (no_init) {
2154         assert(!addmg);
2155         return gv;
2156     }
2157     /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2158      * don't expand it to a glob. This is an optimization so that things
2159      * copying constants over, like Exporter, don't have to be rewritten
2160      * to take into account that you can store more than just globs in
2161      * stashes.
2162      */
2163     else if (no_expand && SvROK(gv)) {
2164         assert(!addmg);
2165         return gv;
2166     }
2167
2168     /* Adding a new symbol.
2169        Unless of course there was already something non-GV here, in which case
2170        we want to behave as if there was always a GV here, containing some sort
2171        of subroutine.
2172        Otherwise we run the risk of creating things like GvIO, which can cause
2173        subtle bugs. eg the one that tripped up SQL::Translator  */
2174
2175     faking_it = SvOK(gv);
2176
2177     if (add & GV_ADDWARN)
2178         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2179                 "Had to create %"UTF8f" unexpectedly",
2180                  UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2181     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2182
2183     if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) )
2184         GvMULTI_on(gv) ;
2185
2186     /* First, store the gv in the symtab if we're adding magic,
2187      * but only for non-empty GVs
2188      */
2189 #define GvEMPTY(gv)      !(GvAV(gv) || GvHV(gv) || GvIO(gv) \
2190                         || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv))))
2191
2192     if ( addmg && !GvEMPTY(gv) ) {
2193         (void)hv_store(stash,name,len,(SV *)gv,0);
2194     }
2195
2196     /* set up magic where warranted */
2197     if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) {
2198         /* See 23496c6 */
2199         if (GvEMPTY(gv)) {
2200             if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) {
2201                 /* The GV was and still is "empty", except that now
2202                  * it has the magic flags turned on, so we want it
2203                  * stored in the symtab.
2204                  */
2205                 (void)hv_store(stash,name,len,(SV *)gv,0);
2206             }
2207             else {
2208                 /* Most likely the temporary GV created above */
2209                 SvREFCNT_dec_NN(gv);
2210                 gv = NULL;
2211             }
2212         }
2213     }
2214
2215     if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2216     return gv;
2217 }
2218
2219 void
2220 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2221 {
2222     const char *name;
2223     const HV * const hv = GvSTASH(gv);
2224
2225     PERL_ARGS_ASSERT_GV_FULLNAME4;
2226
2227     sv_setpv(sv, prefix ? prefix : "");
2228
2229     if (hv && (name = HvNAME(hv))) {
2230       const STRLEN len = HvNAMELEN(hv);
2231       if (keepmain || strnNE(name, "main", len)) {
2232         sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2233         sv_catpvs(sv,"::");
2234       }
2235     }
2236     else sv_catpvs(sv,"__ANON__::");
2237     sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2238 }
2239
2240 void
2241 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2242 {
2243     const GV * const egv = GvEGVx(gv);
2244
2245     PERL_ARGS_ASSERT_GV_EFULLNAME4;
2246
2247     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2248 }
2249
2250
2251 /* recursively scan a stash and any nested stashes looking for entries
2252  * that need the "only used once" warning raised
2253  */
2254
2255 void
2256 Perl_gv_check(pTHX_ HV *stash)
2257 {
2258     I32 i;
2259
2260     PERL_ARGS_ASSERT_GV_CHECK;
2261
2262     if (!HvARRAY(stash))
2263         return;
2264
2265     assert(SvOOK(stash));
2266
2267     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2268         const HE *entry;
2269         /* mark stash is being scanned, to avoid recursing */
2270         HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2271         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2272             GV *gv;
2273             HV *hv;
2274             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2275                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2276             {
2277                 if (hv != PL_defstash && hv != stash
2278                     && !(SvOOK(hv)
2279                         && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2280                 )
2281                      gv_check(hv);              /* nested package */
2282             }
2283             else if ( *HeKEY(entry) != '_'
2284                         && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2285                 const char *file;
2286                 gv = MUTABLE_GV(HeVAL(entry));
2287                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2288                     continue;
2289                 file = GvFILE(gv);
2290                 CopLINE_set(PL_curcop, GvLINE(gv));
2291 #ifdef USE_ITHREADS
2292                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
2293 #else
2294                 CopFILEGV(PL_curcop)
2295                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2296 #endif
2297                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2298                         "Name \"%"HEKf"::%"HEKf
2299                         "\" used only once: possible typo",
2300                             HEKfARG(HvNAME_HEK(stash)),
2301                             HEKfARG(GvNAME_HEK(gv)));
2302             }
2303         }
2304         HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2305     }
2306 }
2307
2308 GV *
2309 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2310 {
2311     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2312     assert(!(flags & ~SVf_UTF8));
2313
2314     return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
2315                                 UTF8fARG(flags, strlen(pack), pack),
2316                                 (long)PL_gensym++),
2317                       GV_ADD, SVt_PVGV);
2318 }
2319
2320 /* hopefully this is only called on local symbol table entries */
2321
2322 GP*
2323 Perl_gp_ref(pTHX_ GP *gp)
2324 {
2325     if (!gp)
2326         return NULL;
2327     gp->gp_refcnt++;
2328     if (gp->gp_cv) {
2329         if (gp->gp_cvgen) {
2330             /* If the GP they asked for a reference to contains
2331                a method cache entry, clear it first, so that we
2332                don't infect them with our cached entry */
2333             SvREFCNT_dec_NN(gp->gp_cv);
2334             gp->gp_cv = NULL;
2335             gp->gp_cvgen = 0;
2336         }
2337     }
2338     return gp;
2339 }
2340
2341 void
2342 Perl_gp_free(pTHX_ GV *gv)
2343 {
2344     GP* gp;
2345     int attempts = 100;
2346
2347     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2348         return;
2349     if (gp->gp_refcnt == 0) {
2350         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2351                          "Attempt to free unreferenced glob pointers"
2352                          pTHX__FORMAT pTHX__VALUE);
2353         return;
2354     }
2355     if (gp->gp_refcnt > 1) {
2356        borrowed:
2357         if (gp->gp_egv == gv)
2358             gp->gp_egv = 0;
2359         gp->gp_refcnt--;
2360         GvGP_set(gv, NULL);
2361         return;
2362     }
2363
2364     while (1) {
2365       /* Copy and null out all the glob slots, so destructors do not see
2366          freed SVs. */
2367       HEK * const file_hek = gp->gp_file_hek;
2368       SV  * const sv       = gp->gp_sv;
2369       AV  * const av       = gp->gp_av;
2370       HV  * const hv       = gp->gp_hv;
2371       IO  * const io       = gp->gp_io;
2372       CV  * const cv       = gp->gp_cv;
2373       CV  * const form     = gp->gp_form;
2374
2375       gp->gp_file_hek = NULL;
2376       gp->gp_sv       = NULL;
2377       gp->gp_av       = NULL;
2378       gp->gp_hv       = NULL;
2379       gp->gp_io       = NULL;
2380       gp->gp_cv       = NULL;
2381       gp->gp_form     = NULL;
2382
2383       if (file_hek)
2384         unshare_hek(file_hek);
2385
2386       SvREFCNT_dec(sv);
2387       SvREFCNT_dec(av);
2388       /* FIXME - another reference loop GV -> symtab -> GV ?
2389          Somehow gp->gp_hv can end up pointing at freed garbage.  */
2390       if (hv && SvTYPE(hv) == SVt_PVHV) {
2391         const HEK *hvname_hek = HvNAME_HEK(hv);
2392         DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", HEKfARG(hvname_hek)));
2393         if (PL_stashcache && hvname_hek)
2394            (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2395         SvREFCNT_dec(hv);
2396       }
2397       SvREFCNT_dec(io);
2398       SvREFCNT_dec(cv);
2399       SvREFCNT_dec(form);
2400
2401       /* Possibly reallocated by a destructor */
2402       gp = GvGP(gv);
2403
2404       if (!gp->gp_file_hek
2405        && !gp->gp_sv
2406        && !gp->gp_av
2407        && !gp->gp_hv
2408        && !gp->gp_io
2409        && !gp->gp_cv
2410        && !gp->gp_form) break;
2411
2412       if (--attempts == 0) {
2413         Perl_die(aTHX_
2414           "panic: gp_free failed to free glob pointer - "
2415           "something is repeatedly re-creating entries"
2416         );
2417       }
2418     }
2419
2420     /* Possibly incremented by a destructor doing glob assignment */
2421     if (gp->gp_refcnt > 1) goto borrowed;
2422     Safefree(gp);
2423     GvGP_set(gv, NULL);
2424 }
2425
2426 int
2427 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2428 {
2429     AMT * const amtp = (AMT*)mg->mg_ptr;
2430     PERL_UNUSED_ARG(sv);
2431
2432     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2433
2434     if (amtp && AMT_AMAGIC(amtp)) {
2435         int i;
2436         for (i = 1; i < NofAMmeth; i++) {
2437             CV * const cv = amtp->table[i];
2438             if (cv) {
2439                 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2440                 amtp->table[i] = NULL;
2441             }
2442         }
2443     }
2444  return 0;
2445 }
2446
2447 /* Updates and caches the CV's */
2448 /* Returns:
2449  * 1 on success and there is some overload
2450  * 0 if there is no overload
2451  * -1 if some error occurred and it couldn't croak
2452  */
2453
2454 int
2455 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2456 {
2457   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2458   AMT amt;
2459   const struct mro_meta* stash_meta = HvMROMETA(stash);
2460   U32 newgen;
2461
2462   PERL_ARGS_ASSERT_GV_AMUPDATE;
2463
2464   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2465   if (mg) {
2466       const AMT * const amtp = (AMT*)mg->mg_ptr;
2467       if (amtp->was_ok_sub == newgen) {
2468           return AMT_AMAGIC(amtp) ? 1 : 0;
2469       }
2470       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2471   }
2472
2473   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2474
2475   Zero(&amt,1,AMT);
2476   amt.was_ok_sub = newgen;
2477   amt.fallback = AMGfallNO;
2478   amt.flags = 0;
2479
2480   {
2481     int filled = 0;
2482     int i;
2483     bool deref_seen = 0;
2484
2485
2486     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2487
2488     /* Try to find via inheritance. */
2489     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2490     SV * const sv = gv ? GvSV(gv) : NULL;
2491     CV* cv;
2492
2493     if (!gv)
2494     {
2495       if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2496         goto no_table;
2497     }
2498 #ifdef PERL_DONT_CREATE_GVSV
2499     else if (!sv) {
2500         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
2501     }
2502 #endif
2503     else if (SvTRUE(sv))
2504         /* don't need to set overloading here because fallback => 1
2505          * is the default setting for classes without overloading */
2506         amt.fallback=AMGfallYES;
2507     else if (SvOK(sv)) {
2508         amt.fallback=AMGfallNEVER;
2509         filled = 1;
2510     }
2511     else {
2512         filled = 1;
2513     }
2514
2515     assert(SvOOK(stash));
2516     /* initially assume the worst */
2517     HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
2518
2519     for (i = 1; i < NofAMmeth; i++) {
2520         const char * const cooky = PL_AMG_names[i];
2521         /* Human-readable form, for debugging: */
2522         const char * const cp = AMG_id2name(i);
2523         const STRLEN l = PL_AMG_namelens[i];
2524
2525         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2526                      cp, HvNAME_get(stash)) );
2527         /* don't fill the cache while looking up!
2528            Creation of inheritance stubs in intermediate packages may
2529            conflict with the logic of runtime method substitution.
2530            Indeed, for inheritance A -> B -> C, if C overloads "+0",
2531            then we could have created stubs for "(+0" in A and C too.
2532            But if B overloads "bool", we may want to use it for
2533            numifying instead of C's "+0". */
2534         gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2535         cv = 0;
2536         if (gv && (cv = GvCV(gv))) {
2537             if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2538               const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2539               if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2540                && strEQ(hvname, "overload")) {
2541                 /* This is a hack to support autoloading..., while
2542                    knowing *which* methods were declared as overloaded. */
2543                 /* GvSV contains the name of the method. */
2544                 GV *ngv = NULL;
2545                 SV *gvsv = GvSV(gv);
2546
2547                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2548                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
2549                              (void*)GvSV(gv), cp, HvNAME(stash)) );
2550                 if (!gvsv || !SvPOK(gvsv)
2551                     || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2552                 {
2553                     /* Can be an import stub (created by "can"). */
2554                     if (destructing) {
2555                         return -1;
2556                     }
2557                     else {
2558                         const SV * const name = (gvsv && SvPOK(gvsv))
2559                                                     ? gvsv
2560                                                     : newSVpvs_flags("???", SVs_TEMP);
2561                         /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2562                         Perl_croak(aTHX_ "%s method \"%"SVf256
2563                                     "\" overloading \"%s\" "\
2564                                     "in package \"%"HEKf256"\"",
2565                                    (GvCVGEN(gv) ? "Stub found while resolving"
2566                                     : "Can't resolve"),
2567                                    SVfARG(name), cp,
2568                                    HEKfARG(
2569                                         HvNAME_HEK(stash)
2570                                    ));
2571                     }
2572                 }
2573                 cv = GvCV(gv = ngv);
2574               }
2575             }
2576             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2577                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2578                          GvNAME(CvGV(cv))) );
2579             filled = 1;
2580         } else if (gv) {                /* Autoloaded... */
2581             cv = MUTABLE_CV(gv);
2582             filled = 1;
2583         }
2584         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2585
2586         if (gv) {
2587             switch (i) {
2588             case to_sv_amg:
2589             case to_av_amg:
2590             case to_hv_amg:
2591             case to_gv_amg:
2592             case to_cv_amg:
2593             case nomethod_amg:
2594                 deref_seen = 1;
2595                 break;
2596             }
2597         }
2598     }
2599     if (!deref_seen)
2600         /* none of @{} etc overloaded; we can do $obj->[N] quicker.
2601          * NB - aux var invalid here, HvARRAY() could have been
2602          * reallocated since it was assigned to */
2603         HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
2604
2605     if (filled) {
2606       AMT_AMAGIC_on(&amt);
2607       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2608                                                 (char*)&amt, sizeof(AMT));
2609       return TRUE;
2610     }
2611   }
2612   /* Here we have no table: */
2613  no_table:
2614   AMT_AMAGIC_off(&amt);
2615   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2616                                                 (char*)&amt, sizeof(AMTS));
2617   return 0;
2618 }
2619
2620
2621 CV*
2622 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2623 {
2624     MAGIC *mg;
2625     AMT *amtp;
2626     U32 newgen;
2627     struct mro_meta* stash_meta;
2628
2629     if (!stash || !HvNAME_get(stash))
2630         return NULL;
2631
2632     stash_meta = HvMROMETA(stash);
2633     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2634
2635     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2636     if (!mg) {
2637       do_update:
2638         if (Gv_AMupdate(stash, 0) == -1)
2639             return NULL;
2640         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2641     }
2642     assert(mg);
2643     amtp = (AMT*)mg->mg_ptr;
2644     if ( amtp->was_ok_sub != newgen )
2645         goto do_update;
2646     if (AMT_AMAGIC(amtp)) {
2647         CV * const ret = amtp->table[id];
2648         if (ret && isGV(ret)) {         /* Autoloading stab */
2649             /* Passing it through may have resulted in a warning
2650                "Inherited AUTOLOAD for a non-method deprecated", since
2651                our caller is going through a function call, not a method call.
2652                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2653             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2654
2655             if (gv && GvCV(gv))
2656                 return GvCV(gv);
2657         }
2658         return ret;
2659     }
2660
2661     return NULL;
2662 }
2663
2664
2665 /* Implement tryAMAGICun_MG macro.
2666    Do get magic, then see if the stack arg is overloaded and if so call it.
2667    Flags:
2668         AMGf_set     return the arg using SETs rather than assigning to
2669                      the targ
2670         AMGf_numeric apply sv_2num to the stack arg.
2671 */
2672
2673 bool
2674 Perl_try_amagic_un(pTHX_ int method, int flags) {
2675     dSP;
2676     SV* tmpsv;
2677     SV* const arg = TOPs;
2678
2679     SvGETMAGIC(arg);
2680
2681     if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2682                                               AMGf_noright | AMGf_unary))) {
2683         if (flags & AMGf_set) {
2684             SETs(tmpsv);
2685         }
2686         else {
2687             dTARGET;
2688             if (SvPADMY(TARG)) {
2689                 sv_setsv(TARG, tmpsv);
2690                 SETTARG;
2691             }
2692             else
2693                 SETs(tmpsv);
2694         }
2695         PUTBACK;
2696         return TRUE;
2697     }
2698
2699     if ((flags & AMGf_numeric) && SvROK(arg))
2700         *sp = sv_2num(arg);
2701     return FALSE;
2702 }
2703
2704
2705 /* Implement tryAMAGICbin_MG macro.
2706    Do get magic, then see if the two stack args are overloaded and if so
2707    call it.
2708    Flags:
2709         AMGf_set     return the arg using SETs rather than assigning to
2710                      the targ
2711         AMGf_assign  op may be called as mutator (eg +=)
2712         AMGf_numeric apply sv_2num to the stack arg.
2713 */
2714
2715 bool
2716 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2717     dSP;
2718     SV* const left = TOPm1s;
2719     SV* const right = TOPs;
2720
2721     SvGETMAGIC(left);
2722     if (left != right)
2723         SvGETMAGIC(right);
2724
2725     if (SvAMAGIC(left) || SvAMAGIC(right)) {
2726         SV * const tmpsv = amagic_call(left, right, method,
2727                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2728         if (tmpsv) {
2729             if (flags & AMGf_set) {
2730                 (void)POPs;
2731                 SETs(tmpsv);
2732             }
2733             else {
2734                 dATARGET;
2735                 (void)POPs;
2736                 if (opASSIGN || SvPADMY(TARG)) {
2737                     sv_setsv(TARG, tmpsv);
2738                     SETTARG;
2739                 }
2740                 else
2741                     SETs(tmpsv);
2742             }
2743             PUTBACK;
2744             return TRUE;
2745         }
2746     }
2747     if(left==right && SvGMAGICAL(left)) {
2748         SV * const left = sv_newmortal();
2749         *(sp-1) = left;
2750         /* Print the uninitialized warning now, so it includes the vari-
2751            able name. */
2752         if (!SvOK(right)) {
2753             if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2754             sv_setsv_flags(left, &PL_sv_no, 0);
2755         }
2756         else sv_setsv_flags(left, right, 0);
2757         SvGETMAGIC(right);
2758     }
2759     if (flags & AMGf_numeric) {
2760         if (SvROK(TOPm1s))
2761             *(sp-1) = sv_2num(TOPm1s);
2762         if (SvROK(right))
2763             *sp     = sv_2num(right);
2764     }
2765     return FALSE;
2766 }
2767
2768 SV *
2769 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2770     SV *tmpsv = NULL;
2771     HV *stash;
2772
2773     PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2774
2775     if (!SvAMAGIC(ref))
2776         return ref;
2777     /* return quickly if none of the deref ops are overloaded */
2778     stash = SvSTASH(SvRV(ref));
2779     assert(SvOOK(stash));
2780     if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
2781         return ref;
2782
2783     while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
2784                                 AMGf_noright | AMGf_unary))) {
2785         if (!SvROK(tmpsv))
2786             Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2787         if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2788             /* Bail out if it returns us the same reference.  */
2789             return tmpsv;
2790         }
2791         ref = tmpsv;
2792         if (!SvAMAGIC(ref))
2793             break;
2794     }
2795     return tmpsv ? tmpsv : ref;
2796 }
2797
2798 bool
2799 Perl_amagic_is_enabled(pTHX_ int method)
2800 {
2801       SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2802
2803       assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2804
2805       if ( !lex_mask || !SvOK(lex_mask) )
2806           /* overloading lexically disabled */
2807           return FALSE;
2808       else if ( lex_mask && SvPOK(lex_mask) ) {
2809           /* we have an entry in the hints hash, check if method has been
2810            * masked by overloading.pm */
2811           STRLEN len;
2812           const int offset = method / 8;
2813           const int bit    = method % 8;
2814           char *pv = SvPV(lex_mask, len);
2815
2816           /* Bit set, so this overloading operator is disabled */
2817           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2818               return FALSE;
2819       }
2820       return TRUE;
2821 }
2822
2823 SV*
2824 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2825 {
2826   dVAR;
2827   MAGIC *mg;
2828   CV *cv=NULL;
2829   CV **cvp=NULL, **ocvp=NULL;
2830   AMT *amtp=NULL, *oamtp=NULL;
2831   int off = 0, off1, lr = 0, notfound = 0;
2832   int postpr = 0, force_cpy = 0;
2833   int assign = AMGf_assign & flags;
2834   const int assignshift = assign ? 1 : 0;
2835   int use_default_op = 0;
2836   int force_scalar = 0;
2837 #ifdef DEBUGGING
2838   int fl=0;
2839 #endif
2840   HV* stash=NULL;
2841
2842   PERL_ARGS_ASSERT_AMAGIC_CALL;
2843
2844   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2845       if (!amagic_is_enabled(method)) return NULL;
2846   }
2847
2848   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2849       && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
2850       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2851       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2852                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2853                         : NULL))
2854       && ((cv = cvp[off=method+assignshift])
2855           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2856                                                           * usual method */
2857                   (
2858 #ifdef DEBUGGING
2859                    fl = 1,
2860 #endif
2861                    cv = cvp[off=method])))) {
2862     lr = -1;                    /* Call method for left argument */
2863   } else {
2864     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2865       int logic;
2866
2867       /* look for substituted methods */
2868       /* In all the covered cases we should be called with assign==0. */
2869          switch (method) {
2870          case inc_amg:
2871            force_cpy = 1;
2872            if ((cv = cvp[off=add_ass_amg])
2873                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2874              right = &PL_sv_yes; lr = -1; assign = 1;
2875            }
2876            break;
2877          case dec_amg:
2878            force_cpy = 1;
2879            if ((cv = cvp[off = subtr_ass_amg])
2880                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2881              right = &PL_sv_yes; lr = -1; assign = 1;
2882            }
2883            break;
2884          case bool__amg:
2885            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2886            break;
2887          case numer_amg:
2888            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2889            break;
2890          case string_amg:
2891            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2892            break;
2893          case not_amg:
2894            (void)((cv = cvp[off=bool__amg])
2895                   || (cv = cvp[off=numer_amg])
2896                   || (cv = cvp[off=string_amg]));
2897            if (cv)
2898                postpr = 1;
2899            break;
2900          case copy_amg:
2901            {
2902              /*
2903                   * SV* ref causes confusion with the interpreter variable of
2904                   * the same name
2905                   */
2906              SV* const tmpRef=SvRV(left);
2907              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2908                 /*
2909                  * Just to be extra cautious.  Maybe in some
2910                  * additional cases sv_setsv is safe, too.
2911                  */
2912                 SV* const newref = newSVsv(tmpRef);
2913                 SvOBJECT_on(newref);
2914                 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2915                    delegate to the stash. */
2916                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2917                 return newref;
2918              }
2919            }
2920            break;
2921          case abs_amg:
2922            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2923                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2924              SV* const nullsv=sv_2mortal(newSViv(0));
2925              if (off1==lt_amg) {
2926                SV* const lessp = amagic_call(left,nullsv,
2927                                        lt_amg,AMGf_noright);
2928                logic = SvTRUE(lessp);
2929              } else {
2930                SV* const lessp = amagic_call(left,nullsv,
2931                                        ncmp_amg,AMGf_noright);
2932                logic = (SvNV(lessp) < 0);
2933              }
2934              if (logic) {
2935                if (off==subtr_amg) {
2936                  right = left;
2937                  left = nullsv;
2938                  lr = 1;
2939                }
2940              } else {
2941                return left;
2942              }
2943            }
2944            break;
2945          case neg_amg:
2946            if ((cv = cvp[off=subtr_amg])) {
2947              right = left;
2948              left = sv_2mortal(newSViv(0));
2949              lr = 1;
2950            }
2951            break;
2952          case int_amg:
2953          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2954          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2955          case regexp_amg:
2956              /* FAIL safe */
2957              return NULL;       /* Delegate operation to standard mechanisms. */
2958
2959          case to_sv_amg:
2960          case to_av_amg:
2961          case to_hv_amg:
2962          case to_gv_amg:
2963          case to_cv_amg:
2964              /* FAIL safe */
2965              return left;       /* Delegate operation to standard mechanisms. */
2966
2967          default:
2968            goto not_found;
2969          }
2970          if (!cv) goto not_found;
2971     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2972                && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
2973                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2974                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2975                           ? (amtp = (AMT*)mg->mg_ptr)->table
2976                           : NULL))
2977                && (cv = cvp[off=method])) { /* Method for right
2978                                              * argument found */
2979       lr=1;
2980     } else if (((cvp && amtp->fallback > AMGfallNEVER)
2981                 || (ocvp && oamtp->fallback > AMGfallNEVER))
2982                && !(flags & AMGf_unary)) {
2983                                 /* We look for substitution for
2984                                  * comparison operations and
2985                                  * concatenation */
2986       if (method==concat_amg || method==concat_ass_amg
2987           || method==repeat_amg || method==repeat_ass_amg) {
2988         return NULL;            /* Delegate operation to string conversion */
2989       }
2990       off = -1;
2991       switch (method) {
2992          case lt_amg:
2993          case le_amg:
2994          case gt_amg:
2995          case ge_amg:
2996          case eq_amg:
2997          case ne_amg:
2998              off = ncmp_amg;
2999              break;
3000          case slt_amg:
3001          case sle_amg:
3002          case sgt_amg:
3003          case sge_amg:
3004          case seq_amg:
3005          case sne_amg:
3006              off = scmp_amg;
3007              break;
3008          }
3009       if (off != -1) {
3010           if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3011               cv = ocvp[off];
3012               lr = -1;
3013           }
3014           if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3015               cv = cvp[off];
3016               lr = 1;
3017           }
3018       }
3019       if (cv)
3020           postpr = 1;
3021       else
3022           goto not_found;
3023     } else {
3024     not_found:                  /* No method found, either report or croak */
3025       switch (method) {
3026          case to_sv_amg:
3027          case to_av_amg:
3028          case to_hv_amg:
3029          case to_gv_amg:
3030          case to_cv_amg:
3031              /* FAIL safe */
3032              return left;       /* Delegate operation to standard mechanisms. */
3033       }
3034       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3035         notfound = 1; lr = -1;
3036       } else if (cvp && (cv=cvp[nomethod_amg])) {
3037         notfound = 1; lr = 1;
3038       } else if ((use_default_op =
3039                   (!ocvp || oamtp->fallback >= AMGfallYES)
3040                   && (!cvp || amtp->fallback >= AMGfallYES))
3041                  && !DEBUG_o_TEST) {
3042         /* Skip generating the "no method found" message.  */
3043         return NULL;
3044       } else {
3045         SV *msg;
3046         if (off==-1) off=method;
3047         msg = sv_2mortal(Perl_newSVpvf(aTHX_
3048                       "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
3049                       AMG_id2name(method + assignshift),
3050                       (flags & AMGf_unary ? " " : "\n\tleft "),
3051                       SvAMAGIC(left)?
3052                         "in overloaded package ":
3053                         "has no overloaded magic",
3054                       SvAMAGIC(left)?
3055                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3056                         SVfARG(&PL_sv_no),
3057                       SvAMAGIC(right)?
3058                         ",\n\tright argument in overloaded package ":
3059                         (flags & AMGf_unary
3060                          ? ""
3061                          : ",\n\tright argument has no overloaded magic"),
3062                       SvAMAGIC(right)?
3063                         SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3064                         SVfARG(&PL_sv_no)));
3065         if (use_default_op) {
3066           DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
3067         } else {
3068           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
3069         }
3070         return NULL;
3071       }
3072       force_cpy = force_cpy || assign;
3073     }
3074   }
3075
3076   switch (method) {
3077     /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3078      * operation. we need this to return a value, so that it can be assigned
3079      * later on, in the postpr block (case inc_amg/dec_amg), even if the
3080      * increment or decrement was itself called in void context */
3081     case inc_amg:
3082       if (off == add_amg)
3083         force_scalar = 1;
3084       break;
3085     case dec_amg:
3086       if (off == subtr_amg)
3087         force_scalar = 1;
3088       break;
3089     /* in these cases, we're calling an assignment variant of an operator
3090      * (+= rather than +, for instance). regardless of whether it's a
3091      * fallback or not, it always has to return a value, which will be
3092      * assigned to the proper variable later */
3093     case add_amg:
3094     case subtr_amg:
3095     case mult_amg:
3096     case div_amg:
3097     case modulo_amg:
3098     case pow_amg:
3099     case lshift_amg:
3100     case rshift_amg:
3101     case repeat_amg:
3102     case concat_amg:
3103     case band_amg:
3104     case bor_amg:
3105     case bxor_amg:
3106       if (assign)
3107         force_scalar = 1;
3108       break;
3109     /* the copy constructor always needs to return a value */
3110     case copy_amg:
3111       force_scalar = 1;
3112       break;
3113     /* because of the way these are implemented (they don't perform the
3114      * dereferencing themselves, they return a reference that perl then
3115      * dereferences later), they always have to be in scalar context */
3116     case to_sv_amg:
3117     case to_av_amg:
3118     case to_hv_amg:
3119     case to_gv_amg:
3120     case to_cv_amg:
3121       force_scalar = 1;
3122       break;
3123     /* these don't have an op of their own; they're triggered by their parent
3124      * op, so the context there isn't meaningful ('$a and foo()' in void
3125      * context still needs to pass scalar context on to $a's bool overload) */
3126     case bool__amg:
3127     case numer_amg:
3128     case string_amg:
3129       force_scalar = 1;
3130       break;
3131   }
3132
3133 #ifdef DEBUGGING
3134   if (!notfound) {
3135     DEBUG_o(Perl_deb(aTHX_
3136                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
3137                      AMG_id2name(off),
3138                      method+assignshift==off? "" :
3139                      " (initially \"",
3140                      method+assignshift==off? "" :
3141                      AMG_id2name(method+assignshift),
3142                      method+assignshift==off? "" : "\")",
3143                      flags & AMGf_unary? "" :
3144                      lr==1 ? " for right argument": " for left argument",
3145                      flags & AMGf_unary? " for argument" : "",
3146                      stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3147                      fl? ",\n\tassignment variant used": "") );
3148   }
3149 #endif
3150     /* Since we use shallow copy during assignment, we need
3151      * to dublicate the contents, probably calling user-supplied
3152      * version of copy operator
3153      */
3154     /* We need to copy in following cases:
3155      * a) Assignment form was called.
3156      *          assignshift==1,  assign==T, method + 1 == off
3157      * b) Increment or decrement, called directly.
3158      *          assignshift==0,  assign==0, method + 0 == off
3159      * c) Increment or decrement, translated to assignment add/subtr.
3160      *          assignshift==0,  assign==T,
3161      *          force_cpy == T
3162      * d) Increment or decrement, translated to nomethod.
3163      *          assignshift==0,  assign==0,
3164      *          force_cpy == T
3165      * e) Assignment form translated to nomethod.
3166      *          assignshift==1,  assign==T, method + 1 != off
3167      *          force_cpy == T
3168      */
3169     /*  off is method, method+assignshift, or a result of opcode substitution.
3170      *  In the latter case assignshift==0, so only notfound case is important.
3171      */
3172   if ( (lr == -1) && ( ( (method + assignshift == off)
3173         && (assign || (method == inc_amg) || (method == dec_amg)))
3174       || force_cpy) )
3175   {
3176       /* newSVsv does not behave as advertised, so we copy missing
3177        * information by hand */
3178       SV *tmpRef = SvRV(left);
3179       SV *rv_copy;
3180       if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3181           SvRV_set(left, rv_copy);
3182           SvSETMAGIC(left);
3183           SvREFCNT_dec_NN(tmpRef);
3184       }
3185   }
3186
3187   {
3188     dSP;
3189     BINOP myop;
3190     SV* res;
3191     const bool oldcatch = CATCH_GET;
3192     I32 oldmark, nret;
3193     int gimme = force_scalar ? G_SCALAR : GIMME_V;
3194
3195     CATCH_SET(TRUE);
3196     Zero(&myop, 1, BINOP);
3197     myop.op_last = (OP *) &myop;
3198     myop.op_next = NULL;
3199     myop.op_flags = OPf_STACKED;
3200
3201     switch (gimme) {
3202         case G_VOID:
3203             myop.op_flags |= OPf_WANT_VOID;
3204             break;
3205         case G_ARRAY:
3206             if (flags & AMGf_want_list) {
3207                 myop.op_flags |= OPf_WANT_LIST;
3208                 break;
3209             }
3210             /* FALLTHROUGH */
3211         default:
3212             myop.op_flags |= OPf_WANT_SCALAR;
3213             break;
3214     }
3215
3216     PUSHSTACKi(PERLSI_OVERLOAD);
3217     ENTER;
3218     SAVEOP();
3219     PL_op = (OP *) &myop;
3220     if (PERLDB_SUB && PL_curstash != PL_debstash)
3221         PL_op->op_private |= OPpENTERSUB_DB;
3222     Perl_pp_pushmark(aTHX);
3223
3224     EXTEND(SP, notfound + 5);
3225     PUSHs(lr>0? right: left);
3226     PUSHs(lr>0? left: right);
3227     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3228     if (notfound) {
3229       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3230                            AMG_id2namelen(method + assignshift), SVs_TEMP));
3231     }
3232     PUSHs(MUTABLE_SV(cv));
3233     PUTBACK;
3234     oldmark = TOPMARK;
3235
3236     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3237       CALLRUNOPS(aTHX);
3238     LEAVE;
3239     SPAGAIN;
3240     nret = SP - (PL_stack_base + oldmark);
3241
3242     switch (gimme) {
3243         case G_VOID:
3244             /* returning NULL has another meaning, and we check the context
3245              * at the call site too, so this can be differentiated from the
3246              * scalar case */
3247             res = &PL_sv_undef;
3248             SP = PL_stack_base + oldmark;
3249             break;
3250         case G_ARRAY: {
3251             if (flags & AMGf_want_list) {
3252                 res = sv_2mortal((SV *)newAV());
3253                 av_extend((AV *)res, nret);
3254                 while (nret--)
3255                     av_store((AV *)res, nret, POPs);
3256                 break;
3257             }
3258             /* FALLTHROUGH */
3259         }
3260         default:
3261             res = POPs;
3262             break;
3263     }
3264
3265     PUTBACK;
3266     POPSTACK;
3267     CATCH_SET(oldcatch);
3268
3269     if (postpr) {
3270       int ans;
3271       switch (method) {
3272       case le_amg:
3273       case sle_amg:
3274         ans=SvIV(res)<=0; break;
3275       case lt_amg:
3276       case slt_amg:
3277         ans=SvIV(res)<0; break;
3278       case ge_amg:
3279       case sge_amg:
3280         ans=SvIV(res)>=0; break;
3281       case gt_amg:
3282       case sgt_amg:
3283         ans=SvIV(res)>0; break;
3284       case eq_amg:
3285       case seq_amg:
3286         ans=SvIV(res)==0; break;
3287       case ne_amg:
3288       case sne_amg:
3289         ans=SvIV(res)!=0; break;
3290       case inc_amg:
3291       case dec_amg:
3292         SvSetSV(left,res); return left;
3293       case not_amg:
3294         ans=!SvTRUE(res); break;
3295       default:
3296         ans=0; break;
3297       }
3298       return boolSV(ans);
3299     } else if (method==copy_amg) {
3300       if (!SvROK(res)) {
3301         Perl_croak(aTHX_ "Copy method did not return a reference");
3302       }
3303       return SvREFCNT_inc(SvRV(res));
3304     } else {
3305       return res;
3306     }
3307   }
3308 }
3309
3310 void
3311 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3312 {
3313     dVAR;
3314     U32 hash;
3315
3316     PERL_ARGS_ASSERT_GV_NAME_SET;
3317
3318     if (len > I32_MAX)
3319         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3320
3321     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3322         unshare_hek(GvNAME_HEK(gv));
3323     }
3324
3325     PERL_HASH(hash, name, len);
3326     GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3327 }
3328
3329 /*
3330 =for apidoc gv_try_downgrade
3331
3332 If the typeglob C<gv> can be expressed more succinctly, by having
3333 something other than a real GV in its place in the stash, replace it
3334 with the optimised form.  Basic requirements for this are that C<gv>
3335 is a real typeglob, is sufficiently ordinary, and is only referenced
3336 from its package.  This function is meant to be used when a GV has been
3337 looked up in part to see what was there, causing upgrading, but based
3338 on what was found it turns out that the real GV isn't required after all.
3339
3340 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3341
3342 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3343 sub, the typeglob is replaced with a scalar-reference placeholder that
3344 more compactly represents the same thing.
3345
3346 =cut
3347 */
3348
3349 void
3350 Perl_gv_try_downgrade(pTHX_ GV *gv)
3351 {
3352     HV *stash;
3353     CV *cv;
3354     HEK *namehek;
3355     SV **gvp;
3356     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3357
3358     /* XXX Why and where does this leave dangling pointers during global
3359        destruction? */
3360     if (PL_phase == PERL_PHASE_DESTRUCT) return;
3361
3362     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3363             !SvOBJECT(gv) && !SvREADONLY(gv) &&
3364             isGV_with_GP(gv) && GvGP(gv) &&
3365             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3366             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3367             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3368         return;
3369     if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3370         return;
3371     if (SvMAGICAL(gv)) {
3372         MAGIC *mg;
3373         /* only backref magic is allowed */
3374         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3375             return;
3376         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3377             if (mg->mg_type != PERL_MAGIC_backref)
3378                 return;
3379         }
3380     }
3381     cv = GvCV(gv);
3382     if (!cv) {
3383         HEK *gvnhek = GvNAME_HEK(gv);
3384         (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3385     } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3386             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3387             CvSTASH(cv) == stash && CvGV(cv) == gv &&
3388             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3389             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3390             (namehek = GvNAME_HEK(gv)) &&
3391             (gvp = hv_fetchhek(stash, namehek, 0)) &&
3392             *gvp == (SV*)gv) {
3393         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3394         const bool imported = !!GvIMPORTED_CV(gv);
3395         SvREFCNT(gv) = 0;
3396         sv_clear((SV*)gv);
3397         SvREFCNT(gv) = 1;
3398         SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3399         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3400                                 STRUCT_OFFSET(XPVIV, xiv_iv));
3401         SvRV_set(gv, value);
3402     }
3403 }
3404
3405 GV *
3406 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3407 {
3408     GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3409     GV * const *gvp;
3410     PERL_ARGS_ASSERT_GV_OVERRIDE;
3411     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3412     gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3413     gv = gvp ? *gvp : NULL;
3414     if (gv && !isGV(gv)) {
3415         if (!SvPCS_IMPORTED(gv)) return NULL;
3416         gv_init(gv, PL_globalstash, name, len, 0);
3417         return gv;
3418     }
3419     return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3420 }
3421
3422 #include "XSUB.h"
3423
3424 static void
3425 core_xsub(pTHX_ CV* cv)
3426 {
3427     Perl_croak(aTHX_
3428        "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3429     );
3430 }
3431
3432 /*
3433  * Local variables:
3434  * c-indentation-style: bsd
3435  * c-basic-offset: 4
3436  * indent-tabs-mode: nil
3437  * End:
3438  *
3439  * ex: set ts=8 sts=4 sw=4 et:
3440  */