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