gv.c

   1 /*    gv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
  13  * of your inquisitiveness, I shall spend all the rest of my days in answering
  14  * you.  What more do you want to know?'
  15  *   'The names of all the stars, and of all living things, and the whole
  16  * history of Middle-earth and Over-heaven and of the Sundering Seas,'
  17  * laughed Pippin.
  18  *
  19  *     [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
  20  */
  21
  22 /*
  23 =head1 GV Functions
  24
  25 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
  26 It is a structure that holds a pointer to a scalar, an array, a hash etc,
  27 corresponding to $foo, @foo, %foo.
  28
  29 GVs are usually found as values in stashes (symbol table hashes) where
  30 Perl stores its global variables.
  31
  32 =cut
  33 */
  34
  35 #include "EXTERN.h"
  36 #define PERL_IN_GV_C
  37 #include "perl.h"
  38 #include "overload.c"
  39
  40 static const char S_autoload[] = "AUTOLOAD";
  41 static const STRLEN S_autolen = sizeof(S_autoload)-1;
  42
  43 GV *
  44 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
  45 {
  46     SV **where;
  47
  48     if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) {
  49         const char *what;
  50         if (type == SVt_PVIO) {
  51             /*
  52              * if it walks like a dirhandle, then let's assume that
  53              * this is a dirhandle.
  54              */
  55             what = PL_op->op_type ==  OP_READDIR ||
  56                 PL_op->op_type ==  OP_TELLDIR ||
  57                 PL_op->op_type ==  OP_SEEKDIR ||
  58                 PL_op->op_type ==  OP_REWINDDIR ||
  59                 PL_op->op_type ==  OP_CLOSEDIR ?
  60                 "dirhandle" : "filehandle";
  61             /* diag_listed_as: Bad symbol for filehandle */
  62         } else if (type == SVt_PVHV) {
  63             what = "hash";
  64         } else {
  65             what = type == SVt_PVAV ? "array" : "scalar";
  66         }
  67         Perl_croak(aTHX_ "Bad symbol for %s", what);
  68     }
  69
  70     if (type == SVt_PVHV) {
  71         where = (SV **)&GvHV(gv);
  72     } else if (type == SVt_PVAV) {
  73         where = (SV **)&GvAV(gv);
  74     } else if (type == SVt_PVIO) {
  75         where = (SV **)&GvIOp(gv);
  76     } else {
  77         where = &GvSV(gv);
  78     }
  79
  80     if (!*where)
  81         *where = newSV_type(type);
  82     return gv;
  83 }
  84
  85 GV *
  86 Perl_gv_fetchfile(pTHX_ const char *name)
  87 {
  88     PERL_ARGS_ASSERT_GV_FETCHFILE;
  89     return gv_fetchfile_flags(name, strlen(name), 0);
  90 }
  91
  92 GV *
  93 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
  94                         const U32 flags)
  95 {
  96     dVAR;
  97     char smallbuf[128];
  98     char *tmpbuf;
  99     const STRLEN tmplen = namelen + 2;
 100     GV *gv;
 101
 102     PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
 103     PERL_UNUSED_ARG(flags);
 104
 105     if (!PL_defstash)
 106         return NULL;
 107
 108     if (tmplen <= sizeof smallbuf)
 109         tmpbuf = smallbuf;
 110     else
 111         Newx(tmpbuf, tmplen, char);
 112     /* This is where the debugger's %{"::_<$filename"} hash is created */
 113     tmpbuf[0] = '_';
 114     tmpbuf[1] = '<';
 115     memcpy(tmpbuf + 2, name, namelen);
 116     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
 117     if (!isGV(gv)) {
 118         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
 119 #ifdef PERL_DONT_CREATE_GVSV
 120         GvSV(gv) = newSVpvn(name, namelen);
 121 #else
 122         sv_setpvn(GvSV(gv), name, namelen);
 123 #endif
 124         if (PERLDB_LINE || PERLDB_SAVESRC)
 125             hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
 126     }
 127     if (tmpbuf != smallbuf)
 128         Safefree(tmpbuf);
 129     return gv;
 130 }
 131
 132 /*
 133 =for apidoc gv_const_sv
 134
 135 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
 136 inlining, or C<gv> is a placeholder reference that would be promoted to such
 137 a typeglob, then returns the value returned by the sub.  Otherwise, returns
 138 NULL.
 139
 140 =cut
 141 */
 142
 143 SV *
 144 Perl_gv_const_sv(pTHX_ GV *gv)
 145 {
 146     PERL_ARGS_ASSERT_GV_CONST_SV;
 147
 148     if (SvTYPE(gv) == SVt_PVGV)
 149         return cv_const_sv(GvCVu(gv));
 150     return SvROK(gv) ? SvRV(gv) : NULL;
 151 }
 152
 153 GP *
 154 Perl_newGP(pTHX_ GV *const gv)
 155 {
 156     GP *gp;
 157     U32 hash;
 158 #ifdef USE_ITHREADS
 159     const char *const file
 160         = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
 161     const STRLEN len = strlen(file);
 162 #else
 163     SV *const temp_sv = CopFILESV(PL_curcop);
 164     const char *file;
 165     STRLEN len;
 166
 167     PERL_ARGS_ASSERT_NEWGP;
 168
 169     if (temp_sv) {
 170         file = SvPVX(temp_sv);
 171         len = SvCUR(temp_sv);
 172     } else {
 173         file = "";
 174         len = 0;
 175     }
 176 #endif
 177
 178     PERL_HASH(hash, file, len);
 179
 180     Newxz(gp, 1, GP);
 181
 182 #ifndef PERL_DONT_CREATE_GVSV
 183     gp->gp_sv = newSV(0);
 184 #endif
 185
 186     gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
 187     /* XXX Ideally this cast would be replaced with a change to const char*
 188        in the struct.  */
 189     gp->gp_file_hek = share_hek(file, len, hash);
 190     gp->gp_egv = gv;
 191     gp->gp_refcnt = 1;
 192
 193     return gp;
 194 }
 195
 196 void
 197 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 198 {
 199     dVAR;
 200     const U32 old_type = SvTYPE(gv);
 201     const bool doproto = old_type > SVt_NULL;
 202     char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
 203     const STRLEN protolen = proto ? SvCUR(gv) : 0;
 204     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
 205     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
 206
 207     PERL_ARGS_ASSERT_GV_INIT;
 208     assert (!(proto && has_constant));
 209
 210     if (has_constant) {
 211         /* The constant has to be a simple scalar type.  */
 212         switch (SvTYPE(has_constant)) {
 213         case SVt_PVAV:
 214         case SVt_PVHV:
 215         case SVt_PVCV:
 216         case SVt_PVFM:
 217         case SVt_PVIO:
 218             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
 219                        sv_reftype(has_constant, 0));
 220         default: NOOP;
 221         }
 222         SvRV_set(gv, NULL);
 223         SvROK_off(gv);
 224     }
 225
 226
 227     if (old_type < SVt_PVGV) {
 228         if (old_type >= SVt_PV)
 229             SvCUR_set(gv, 0);
 230         sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
 231     }
 232     if (SvLEN(gv)) {
 233         if (proto) {
 234             SvPV_set(gv, NULL);
 235             SvLEN_set(gv, 0);
 236             SvPOK_off(gv);
 237         } else
 238             Safefree(SvPVX_mutable(gv));
 239     }
 240     SvIOK_off(gv);
 241     isGV_with_GP_on(gv);
 242
 243     GvGP(gv) = Perl_newGP(aTHX_ gv);
 244     GvSTASH(gv) = stash;
 245     if (stash)
 246         Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
 247     gv_name_set(gv, name, len, GV_ADD);
 248     if (multi || doproto)              /* doproto means it _was_ mentioned */
 249         GvMULTI_on(gv);
 250     if (doproto) {                      /* Replicate part of newSUB here. */
 251         ENTER;
 252         if (has_constant) {
 253             /* newCONSTSUB takes ownership of the reference from us.  */
 254             GvCV(gv) = newCONSTSUB(stash, name, has_constant);
 255             /* If this reference was a copy of another, then the subroutine
 256                must have been "imported", by a Perl space assignment to a GV
 257                from a reference to CV.  */
 258             if (exported_constant)
 259                 GvIMPORTED_CV_on(gv);
 260         } else {
 261             (void) start_subparse(0,0); /* Create empty CV in compcv. */
 262             GvCV(gv) = PL_compcv;
 263         }
 264         LEAVE;
 265
 266         mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
 267         CvGV(GvCV(gv)) = gv;
 268         CvFILE_set_from_cop(GvCV(gv), PL_curcop);
 269         CvSTASH(GvCV(gv)) = PL_curstash;
 270         if (proto) {
 271             sv_usepvn_flags(MUTABLE_SV(GvCV(gv)), proto, protolen,
 272                             SV_HAS_TRAILING_NUL);
 273         }
 274     }
 275 }
 276
 277 STATIC void
 278 S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type)
 279 {
 280     PERL_ARGS_ASSERT_GV_INIT_SV;
 281
 282     switch (sv_type) {
 283     case SVt_PVIO:
 284         (void)GvIOn(gv);
 285         break;
 286     case SVt_PVAV:
 287         (void)GvAVn(gv);
 288         break;
 289     case SVt_PVHV:
 290         (void)GvHVn(gv);
 291         break;
 292 #ifdef PERL_DONT_CREATE_GVSV
 293     case SVt_NULL:
 294     case SVt_PVCV:
 295     case SVt_PVFM:
 296     case SVt_PVGV:
 297         break;
 298     default:
 299         if(GvSVn(gv)) {
 300             /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
 301                If we just cast GvSVn(gv) to void, it ignores evaluating it for
 302                its side effect */
 303         }
 304 #endif
 305     }
 306 }
 307
 308 /*
 309 =for apidoc gv_fetchmeth
 310
 311 Returns the glob with the given C<name> and a defined subroutine or
 312 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
 313 accessible via @ISA and UNIVERSAL::.
 314
 315 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 316 side-effect creates a glob with the given C<name> in the given C<stash>
 317 which in the case of success contains an alias for the subroutine, and sets
 318 up caching info for this glob.
 319
 320 This function grants C<"SUPER"> token as a postfix of the stash name. The
 321 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 322 visible to Perl code.  So when calling C<call_sv>, you should not use
 323 the GV directly; instead, you should use the method's CV, which can be
 324 obtained from the GV with the C<GvCV> macro.
 325
 326 =cut
 327 */
 328
 329 /* NOTE: No support for tied ISA */
 330
 331 GV *
 332 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 333 {
 334     dVAR;
 335     GV** gvp;
 336     AV* linear_av;
 337     SV** linear_svp;
 338     SV* linear_sv;
 339     HV* cstash;
 340     GV* candidate = NULL;
 341     CV* cand_cv = NULL;
 342     CV* old_cv;
 343     GV* topgv = NULL;
 344     const char *hvname;
 345     I32 create = (level >= 0) ? 1 : 0;
 346     I32 items;
 347     STRLEN packlen;
 348     U32 topgen_cmp;
 349
 350     PERL_ARGS_ASSERT_GV_FETCHMETH;
 351
 352     /* UNIVERSAL methods should be callable without a stash */
 353     if (!stash) {
 354         create = 0;  /* probably appropriate */
 355         if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
 356             return 0;
 357     }
 358
 359     assert(stash);
 360
 361     hvname = HvNAME_get(stash);
 362     if (!hvname)
 363       Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 364
 365     assert(hvname);
 366     assert(name);
 367
 368     DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
 369
 370     topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
 371
 372     /* check locally for a real method or a cache entry */
 373     gvp = (GV**)hv_fetch(stash, name, len, create);
 374     if(gvp) {
 375         topgv = *gvp;
 376         assert(topgv);
 377         if (SvTYPE(topgv) != SVt_PVGV)
 378             gv_init(topgv, stash, name, len, TRUE);
 379         if ((cand_cv = GvCV(topgv))) {
 380             /* If genuine method or valid cache entry, use it */
 381             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
 382                 return topgv;
 383             }
 384             else {
 385                 /* stale cache entry, junk it and move on */
 386                 SvREFCNT_dec(cand_cv);
 387                 GvCV(topgv) = cand_cv = NULL;
 388                 GvCVGEN(topgv) = 0;
 389             }
 390         }
 391         else if (GvCVGEN(topgv) == topgen_cmp) {
 392             /* cache indicates no such method definitively */
 393             return 0;
 394         }
 395     }
 396
 397     packlen = HvNAMELEN_get(stash);
 398     if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
 399         HV* basestash;
 400         packlen -= 7;
 401         basestash = gv_stashpvn(hvname, packlen, GV_ADD);
 402         linear_av = mro_get_linear_isa(basestash);
 403     }
 404     else {
 405         linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
 406     }
 407
 408     linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
 409     items = AvFILLp(linear_av); /* no +1, to skip over self */
 410     while (items--) {
 411         linear_sv = *linear_svp++;
 412         assert(linear_sv);
 413         cstash = gv_stashsv(linear_sv, 0);
 414
 415         if (!cstash) {
 416             if (ckWARN(WARN_SYNTAX))
 417                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
 418                     SVfARG(linear_sv), hvname);
 419             continue;
 420         }
 421
 422         assert(cstash);
 423
 424         gvp = (GV**)hv_fetch(cstash, name, len, 0);
 425         if (!gvp) continue;
 426         candidate = *gvp;
 427         assert(candidate);
 428         if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
 429         if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 430             /*
 431              * Found real method, cache method in topgv if:
 432              *  1. topgv has no synonyms (else inheritance crosses wires)
 433              *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 434              */
 435             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 436                   if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
 437                   SvREFCNT_inc_simple_void_NN(cand_cv);
 438                   GvCV(topgv) = cand_cv;
 439                   GvCVGEN(topgv) = topgen_cmp;
 440             }
 441             return candidate;
 442         }
 443     }
 444
 445     /* Check UNIVERSAL without caching */
 446     if(level == 0 || level == -1) {
 447         candidate = gv_fetchmeth(NULL, name, len, 1);
 448         if(candidate) {
 449             cand_cv = GvCV(candidate);
 450             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 451                   if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
 452                   SvREFCNT_inc_simple_void_NN(cand_cv);
 453                   GvCV(topgv) = cand_cv;
 454                   GvCVGEN(topgv) = topgen_cmp;
 455             }
 456             return candidate;
 457         }
 458     }
 459
 460     if (topgv && GvREFCNT(topgv) == 1) {
 461         /* cache the fact that the method is not defined */
 462         GvCVGEN(topgv) = topgen_cmp;
 463     }
 464
 465     return 0;
 466 }
 467
 468 /*
 469 =for apidoc gv_fetchmeth_autoload
 470
 471 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
 472 Returns a glob for the subroutine.
 473
 474 For an autoloaded subroutine without a GV, will create a GV even
 475 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
 476 of the result may be zero.
 477
 478 =cut
 479 */
 480
 481 GV *
 482 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 483 {
 484     GV *gv = gv_fetchmeth(stash, name, len, level);
 485
 486     PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD;
 487
 488     if (!gv) {
 489         CV *cv;
 490         GV **gvp;
 491
 492         if (!stash)
 493             return NULL;        /* UNIVERSAL::AUTOLOAD could cause trouble */
 494         if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
 495             return NULL;
 496         if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
 497             return NULL;
 498         cv = GvCV(gv);
 499         if (!(CvROOT(cv) || CvXSUB(cv)))
 500             return NULL;
 501         /* Have an autoload */
 502         if (level < 0)  /* Cannot do without a stub */
 503             gv_fetchmeth(stash, name, len, 0);
 504         gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 505         if (!gvp)
 506             return NULL;
 507         return *gvp;
 508     }
 509     return gv;
 510 }
 511
 512 /*
 513 =for apidoc gv_fetchmethod_autoload
 514
 515 Returns the glob which contains the subroutine to call to invoke the method
 516 on the C<stash>.  In fact in the presence of autoloading this may be the
 517 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
 518 already setup.
 519
 520 The third parameter of C<gv_fetchmethod_autoload> determines whether
 521 AUTOLOAD lookup is performed if the given method is not present: non-zero
 522 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
 523 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
 524 with a non-zero C<autoload> parameter.
 525
 526 These functions grant C<"SUPER"> token as a prefix of the method name. Note
 527 that if you want to keep the returned glob for a long time, you need to
 528 check for it being "AUTOLOAD", since at the later time the call may load a
 529 different subroutine due to $AUTOLOAD changing its value. Use the glob
 530 created via a side effect to do this.
 531
 532 These functions have the same side-effects and as C<gv_fetchmeth> with
 533 C<level==0>.  C<name> should be writable if contains C<':'> or C<'
 534 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
 535 C<call_sv> apply equally to these functions.
 536
 537 =cut
 538 */
 539
 540 STATIC HV*
 541 S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
 542 {
 543     AV* superisa;
 544     GV** gvp;
 545     GV* gv;
 546     HV* stash;
 547
 548     PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
 549
 550     stash = gv_stashpvn(name, namelen, 0);
 551     if(stash) return stash;
 552
 553     /* If we must create it, give it an @ISA array containing
 554        the real package this SUPER is for, so that it's tied
 555        into the cache invalidation code correctly */
 556     stash = gv_stashpvn(name, namelen, GV_ADD);
 557     gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
 558     gv = *gvp;
 559     gv_init(gv, stash, "ISA", 3, TRUE);
 560     superisa = GvAVn(gv);
 561     GvMULTI_on(gv);
 562     sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
 563 #ifdef USE_ITHREADS
 564     av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0));
 565 #else
 566     av_push(superisa, newSVhek(CopSTASH(PL_curcop)
 567                                ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
 568 #endif
 569
 570     return stash;
 571 }
 572
 573 GV *
 574 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 575 {
 576     PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
 577
 578     return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
 579 }
 580
 581 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
 582    even a U32 hash */
 583 GV *
 584 Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
 585 {
 586     dVAR;
 587     register const char *nend;
 588     const char *nsplit = NULL;
 589     GV* gv;
 590     HV* ostash = stash;
 591     const char * const origname = name;
 592     SV *const error_report = MUTABLE_SV(stash);
 593     const U32 autoload = flags & GV_AUTOLOAD;
 594     const U32 do_croak = flags & GV_CROAK;
 595
 596     PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS;
 597
 598     if (SvTYPE(stash) < SVt_PVHV)
 599         stash = NULL;
 600     else {
 601         /* The only way stash can become NULL later on is if nsplit is set,
 602            which in turn means that there is no need for a SVt_PVHV case
 603            the error reporting code.  */
 604     }
 605
 606     for (nend = name; *nend; nend++) {
 607         if (*nend == '\'') {
 608             nsplit = nend;
 609             name = nend + 1;
 610         }
 611         else if (*nend == ':' && *(nend + 1) == ':') {
 612             nsplit = nend++;
 613             name = nend + 1;
 614         }
 615     }
 616     if (nsplit) {
 617         if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
 618             /* ->SUPER::method should really be looked up in original stash */
 619             SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
 620                                                   CopSTASHPV(PL_curcop)));
 621             /* __PACKAGE__::SUPER stash should be autovivified */
 622             stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr));
 623             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
 624                          origname, HvNAME_get(stash), name) );
 625         }
 626         else {
 627             /* don't autovifify if ->NoSuchStash::method */
 628             stash = gv_stashpvn(origname, nsplit - origname, 0);
 629
 630             /* however, explicit calls to Pkg::SUPER::method may
 631                happen, and may require autovivification to work */
 632             if (!stash && (nsplit - origname) >= 7 &&
 633                 strnEQ(nsplit - 7, "::SUPER", 7) &&
 634                 gv_stashpvn(origname, nsplit - origname - 7, 0))
 635               stash = gv_get_super_pkg(origname, nsplit - origname);
 636         }
 637         ostash = stash;
 638     }
 639
 640     gv = gv_fetchmeth(stash, name, nend - name, 0);
 641     if (!gv) {
 642         if (strEQ(name,"import") || strEQ(name,"unimport"))
 643             gv = MUTABLE_GV(&PL_sv_yes);
 644         else if (autoload)
 645             gv = gv_autoload4(ostash, name, nend - name, TRUE);
 646         if (!gv && do_croak) {
 647             /* Right now this is exclusively for the benefit of S_method_common
 648                in pp_hot.c  */
 649             if (stash) {
 650                 Perl_croak(aTHX_
 651                            "Can't locate object method \"%s\" via package \"%.*s\"",
 652                            name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
 653             }
 654             else {
 655                 STRLEN packlen;
 656                 const char *packname;
 657
 658                 if (nsplit) {
 659                     packlen = nsplit - origname;
 660                     packname = origname;
 661                 } else {
 662                     packname = SvPV_const(error_report, packlen);
 663                 }
 664
 665                 Perl_croak(aTHX_
 666                            "Can't locate object method \"%s\" via package \"%.*s\""
 667                            " (perhaps you forgot to load \"%.*s\"?)",
 668                            name, (int)packlen, packname, (int)packlen, packname);
 669             }
 670         }
 671     }
 672     else if (autoload) {
 673         CV* const cv = GvCV(gv);
 674         if (!CvROOT(cv) && !CvXSUB(cv)) {
 675             GV* stubgv;
 676             GV* autogv;
 677
 678             if (CvANON(cv))
 679                 stubgv = gv;
 680             else {
 681                 stubgv = CvGV(cv);
 682                 if (GvCV(stubgv) != cv)         /* orphaned import */
 683                     stubgv = gv;
 684             }
 685             autogv = gv_autoload4(GvSTASH(stubgv),
 686                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
 687             if (autogv)
 688                 gv = autogv;
 689         }
 690     }
 691
 692     return gv;
 693 }
 694
 695 GV*
 696 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 697 {
 698     dVAR;
 699     GV* gv;
 700     CV* cv;
 701     HV* varstash;
 702     GV* vargv;
 703     SV* varsv;
 704     const char *packname = "";
 705     STRLEN packname_len = 0;
 706
 707     PERL_ARGS_ASSERT_GV_AUTOLOAD4;
 708
 709     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
 710         return NULL;
 711     if (stash) {
 712         if (SvTYPE(stash) < SVt_PVHV) {
 713             packname = SvPV_const(MUTABLE_SV(stash), packname_len);
 714             stash = NULL;
 715         }
 716         else {
 717             packname = HvNAME_get(stash);
 718             packname_len = HvNAMELEN_get(stash);
 719         }
 720     }
 721     if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
 722         return NULL;
 723     cv = GvCV(gv);
 724
 725     if (!(CvROOT(cv) || CvXSUB(cv)))
 726         return NULL;
 727
 728     /*
 729      * Inheriting AUTOLOAD for non-methods works ... for now.
 730      */
 731     if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
 732         && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
 733     )
 734         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 735           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 736              packname, (int)len, name);
 737
 738     if (CvISXSUB(cv)) {
 739         /* rather than lookup/init $AUTOLOAD here
 740          * only to have the XSUB do another lookup for $AUTOLOAD
 741          * and split that value on the last '::',
 742          * pass along the same data via some unused fields in the CV
 743          */
 744         CvSTASH(cv) = stash;
 745         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
 746         SvCUR_set(cv, len);
 747         return gv;
 748     }
 749
 750     /*
 751      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
 752      * The subroutine's original name may not be "AUTOLOAD", so we don't
 753      * use that, but for lack of anything better we will use the sub's
 754      * original package to look up $AUTOLOAD.
 755      */
 756     varstash = GvSTASH(CvGV(cv));
 757     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
 758     ENTER;
 759
 760     if (!isGV(vargv)) {
 761         gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
 762 #ifdef PERL_DONT_CREATE_GVSV
 763         GvSV(vargv) = newSV(0);
 764 #endif
 765     }
 766     LEAVE;
 767     varsv = GvSVn(vargv);
 768     sv_setpvn(varsv, packname, packname_len);
 769     sv_catpvs(varsv, "::");
 770     sv_catpvn(varsv, name, len);
 771     return gv;
 772 }
 773
 774
 775 /* require_tie_mod() internal routine for requiring a module
 776  * that implements the logic of automatical ties like %! and %-
 777  *
 778  * The "gv" parameter should be the glob.
 779  * "varpv" holds the name of the var, used for error messages.
 780  * "namesv" holds the module name. Its refcount will be decremented.
 781  * "methpv" holds the method name to test for to check that things
 782  *   are working reasonably close to as expected.
 783  * "flags": if flag & 1 then save the scalar before loading.
 784  * For the protection of $! to work (it is set by this routine)
 785  * the sv slot must already be magicalized.
 786  */
 787 STATIC HV*
 788 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
 789 {
 790     dVAR;
 791     HV* stash = gv_stashsv(namesv, 0);
 792
 793     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
 794
 795     if (!stash || !(gv_fetchmethod(stash, methpv))) {
 796         SV *module = newSVsv(namesv);
 797         char varname = *varpv; /* varpv might be clobbered by load_module,
 798                                   so save it. For the moment it's always
 799                                   a single char. */
 800         dSP;
 801         ENTER;
 802         if ( flags & 1 )
 803             save_scalar(gv);
 804         PUSHSTACKi(PERLSI_MAGIC);
 805         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
 806         POPSTACK;
 807         LEAVE;
 808         SPAGAIN;
 809         stash = gv_stashsv(namesv, 0);
 810         if (!stash)
 811             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
 812                     varname, SVfARG(namesv));
 813         else if (!gv_fetchmethod(stash, methpv))
 814             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
 815                     varname, SVfARG(namesv), methpv);
 816     }
 817     SvREFCNT_dec(namesv);
 818     return stash;
 819 }
 820
 821 /*
 822 =for apidoc gv_stashpv
 823
 824 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
 825 determine the length of C<name>, then calls C<gv_stashpvn()>.
 826
 827 =cut
 828 */
 829
 830 HV*
 831 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 832 {
 833     PERL_ARGS_ASSERT_GV_STASHPV;
 834     return gv_stashpvn(name, strlen(name), create);
 835 }
 836
 837 /*
 838 =for apidoc gv_stashpvn
 839
 840 Returns a pointer to the stash for a specified package.  The C<namelen>
 841 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
 842 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
 843 created if it does not already exist.  If the package does not exist and
 844 C<flags> is 0 (or any other setting that does not create packages) then NULL
 845 is returned.
 846
 847
 848 =cut
 849 */
 850
 851 HV*
 852 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
 853 {
 854     char smallbuf[128];
 855     char *tmpbuf;
 856     HV *stash;
 857     GV *tmpgv;
 858
 859     PERL_ARGS_ASSERT_GV_STASHPVN;
 860
 861     if (namelen + 2 <= sizeof smallbuf)
 862         tmpbuf = smallbuf;
 863     else
 864         Newx(tmpbuf, namelen + 2, char);
 865     Copy(name,tmpbuf,namelen,char);
 866     tmpbuf[namelen++] = ':';
 867     tmpbuf[namelen++] = ':';
 868     tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, flags, SVt_PVHV);
 869     if (tmpbuf != smallbuf)
 870         Safefree(tmpbuf);
 871     if (!tmpgv)
 872         return NULL;
 873     if (!GvHV(tmpgv))
 874         GvHV(tmpgv) = newHV();
 875     stash = GvHV(tmpgv);
 876     if (!HvNAME_get(stash))
 877         hv_name_set(stash, name, namelen, 0);
 878     return stash;
 879 }
 880
 881 /*
 882 =for apidoc gv_stashsv
 883
 884 Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
 885
 886 =cut
 887 */
 888
 889 HV*
 890 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
 891 {
 892     STRLEN len;
 893     const char * const ptr = SvPV_const(sv,len);
 894
 895     PERL_ARGS_ASSERT_GV_STASHSV;
 896
 897     return gv_stashpvn(ptr, len, flags);
 898 }
 899
 900
 901 GV *
 902 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
 903     PERL_ARGS_ASSERT_GV_FETCHPV;
 904     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
 905 }
 906
 907 GV *
 908 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
 909     STRLEN len;
 910     const char * const nambeg = SvPV_const(name, len);
 911     PERL_ARGS_ASSERT_GV_FETCHSV;
 912     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
 913 }
 914
 915 GV *
 916 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 917                        const svtype sv_type)
 918 {
 919     dVAR;
 920     register const char *name = nambeg;
 921     register GV *gv = NULL;
 922     GV**gvp;
 923     I32 len;
 924     register const char *name_cursor;
 925     HV *stash = NULL;
 926     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
 927     const I32 no_expand = flags & GV_NOEXPAND;
 928     const I32 add = flags & ~GV_NOADD_MASK;
 929     const char *const name_end = nambeg + full_len;
 930     const char *const name_em1 = name_end - 1;
 931     U32 faking_it;
 932
 933     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
 934
 935     if (flags & GV_NOTQUAL) {
 936         /* Caller promised that there is no stash, so we can skip the check. */
 937         len = full_len;
 938         goto no_stash;
 939     }
 940
 941     if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
 942         /* accidental stringify on a GV? */
 943         name++;
 944     }
 945
 946     for (name_cursor = name; name_cursor < name_end; name_cursor++) {
 947         if ((*name_cursor == ':' && name_cursor < name_em1
 948              && name_cursor[1] == ':')
 949             || (*name_cursor == '\'' && name_cursor[1]))
 950         {
 951             if (!stash)
 952                 stash = PL_defstash;
 953             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 954                 return NULL;
 955
 956             len = name_cursor - name;
 957             if (len > 0) {
 958                 char smallbuf[128];
 959                 char *tmpbuf;
 960
 961                 if (len + 2 <= (I32)sizeof (smallbuf))
 962                     tmpbuf = smallbuf;
 963                 else
 964                     Newx(tmpbuf, len+2, char);
 965                 Copy(name, tmpbuf, len, char);
 966                 tmpbuf[len++] = ':';
 967                 tmpbuf[len++] = ':';
 968                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 969                 gv = gvp ? *gvp : NULL;
 970                 if (gv && gv != (const GV *)&PL_sv_undef) {
 971                     if (SvTYPE(gv) != SVt_PVGV)
 972                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 973                     else
 974                         GvMULTI_on(gv);
 975                 }
 976                 if (tmpbuf != smallbuf)
 977                     Safefree(tmpbuf);
 978                 if (!gv || gv == (const GV *)&PL_sv_undef)
 979                     return NULL;
 980
 981                 if (!(stash = GvHV(gv)))
 982                     stash = GvHV(gv) = newHV();
 983
 984                 if (!HvNAME_get(stash))
 985                     hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
 986             }
 987
 988             if (*name_cursor == ':')
 989                 name_cursor++;
 990             name_cursor++;
 991             name = name_cursor;
 992             if (name == name_end)
 993                 return gv
 994                     ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
 995         }
 996     }
 997     len = name_cursor - name;
 998
 999     /* No stash in name, so see how we can default */
1000
1001     if (!stash) {
1002     no_stash:
1003         if (len && isIDFIRST_lazy(name)) {
1004             bool global = FALSE;
1005
1006             switch (len) {
1007             case 1:
1008                 if (*name == '_')
1009                     global = TRUE;
1010                 break;
1011             case 3:
1012                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1013                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1014                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1015                     global = TRUE;
1016                 break;
1017             case 4:
1018                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1019                     && name[3] == 'V')
1020                     global = TRUE;
1021                 break;
1022             case 5:
1023                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1024                     && name[3] == 'I' && name[4] == 'N')
1025                     global = TRUE;
1026                 break;
1027             case 6:
1028                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1029                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1030                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1031                     global = TRUE;
1032                 break;
1033             case 7:
1034                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1035                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1036                     && name[6] == 'T')
1037                     global = TRUE;
1038                 break;
1039             }
1040
1041             if (global)
1042                 stash = PL_defstash;
1043             else if (IN_PERL_COMPILETIME) {
1044                 stash = PL_curstash;
1045                 if (add && (PL_hints & HINT_STRICT_VARS) &&
1046                     sv_type != SVt_PVCV &&
1047                     sv_type != SVt_PVGV &&
1048                     sv_type != SVt_PVFM &&
1049                     sv_type != SVt_PVIO &&
1050                     !(len == 1 && sv_type == SVt_PV &&
1051                       (*name == 'a' || *name == 'b')) )
1052                 {
1053                     gvp = (GV**)hv_fetch(stash,name,len,0);
1054                     if (!gvp ||
1055                         *gvp == (const GV *)&PL_sv_undef ||
1056                         SvTYPE(*gvp) != SVt_PVGV)
1057                     {
1058                         stash = NULL;
1059                     }
1060                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1061                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1062                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1063                     {
1064                         /* diag_listed_as: Variable "%s" is not imported%s */
1065                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
1066                             sv_type == SVt_PVAV ? '@' :
1067                             sv_type == SVt_PVHV ? '%' : '$',
1068                             name);
1069                         if (GvCVu(*gvp))
1070                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
1071                         stash = NULL;
1072                     }
1073                 }
1074             }
1075             else
1076                 stash = CopSTASH(PL_curcop);
1077         }
1078         else
1079             stash = PL_defstash;
1080     }
1081
1082     /* By this point we should have a stash and a name */
1083
1084     if (!stash) {
1085         if (add) {
1086             SV * const err = Perl_mess(aTHX_
1087                  "Global symbol \"%s%s\" requires explicit package name",
1088                  (sv_type == SVt_PV ? "$"
1089                   : sv_type == SVt_PVAV ? "@"
1090                   : sv_type == SVt_PVHV ? "%"
1091                   : ""), name);
1092             GV *gv;
1093             if (USE_UTF8_IN_NAMES)
1094                 SvUTF8_on(err);
1095             qerror(err);
1096             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1097             if(!gv) {
1098                 /* symbol table under destruction */
1099                 return NULL;
1100             }
1101             stash = GvHV(gv);
1102         }
1103         else
1104             return NULL;
1105     }
1106
1107     if (!SvREFCNT(stash))       /* symbol table under destruction */
1108         return NULL;
1109
1110     gvp = (GV**)hv_fetch(stash,name,len,add);
1111     if (!gvp || *gvp == (const GV *)&PL_sv_undef)
1112         return NULL;
1113     gv = *gvp;
1114     if (SvTYPE(gv) == SVt_PVGV) {
1115         if (add) {
1116             GvMULTI_on(gv);
1117             gv_init_sv(gv, sv_type);
1118             if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1119                 if (*name == '!')
1120                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1121                 else if (*name == '-' || *name == '+')
1122                     require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1123             }
1124         }
1125         return gv;
1126     } else if (no_init) {
1127         return gv;
1128     } else if (no_expand && SvROK(gv)) {
1129         return gv;
1130     }
1131
1132     /* Adding a new symbol.
1133        Unless of course there was already something non-GV here, in which case
1134        we want to behave as if there was always a GV here, containing some sort
1135        of subroutine.
1136        Otherwise we run the risk of creating things like GvIO, which can cause
1137        subtle bugs. eg the one that tripped up SQL::Translator  */
1138
1139     faking_it = SvOK(gv);
1140
1141     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
1142         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1143     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1144     gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
1145
1146     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1147                                             : (PL_dowarn & G_WARN_ON ) ) )
1148         GvMULTI_on(gv) ;
1149
1150     /* set up magic where warranted */
1151     if (len > 1) {
1152 #ifndef EBCDIC
1153         if (*name > 'V' ) {
1154             NOOP;
1155             /* Nothing else to do.
1156                The compiler will probably turn the switch statement into a
1157                branch table. Make sure we avoid even that small overhead for
1158                the common case of lower case variable names.  */
1159         } else
1160 #endif
1161         {
1162             const char * const name2 = name + 1;
1163             switch (*name) {
1164             case 'A':
1165                 if (strEQ(name2, "RGV")) {
1166                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1167                 }
1168                 else if (strEQ(name2, "RGVOUT")) {
1169                     GvMULTI_on(gv);
1170                 }
1171                 break;
1172             case 'E':
1173                 if (strnEQ(name2, "XPORT", 5))
1174                     GvMULTI_on(gv);
1175                 break;
1176             case 'I':
1177                 if (strEQ(name2, "SA")) {
1178                     AV* const av = GvAVn(gv);
1179                     GvMULTI_on(gv);
1180                     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1181                              NULL, 0);
1182                     /* NOTE: No support for tied ISA */
1183                     if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
1184                         && AvFILLp(av) == -1)
1185                         {
1186                             av_push(av, newSVpvs("NDBM_File"));
1187                             gv_stashpvs("NDBM_File", GV_ADD);
1188                             av_push(av, newSVpvs("DB_File"));
1189                             gv_stashpvs("DB_File", GV_ADD);
1190                             av_push(av, newSVpvs("GDBM_File"));
1191                             gv_stashpvs("GDBM_File", GV_ADD);
1192                             av_push(av, newSVpvs("SDBM_File"));
1193                             gv_stashpvs("SDBM_File", GV_ADD);
1194                             av_push(av, newSVpvs("ODBM_File"));
1195                             gv_stashpvs("ODBM_File", GV_ADD);
1196                         }
1197                 }
1198                 break;
1199             case 'O':
1200                 if (strEQ(name2, "VERLOAD")) {
1201                     HV* const hv = GvHVn(gv);
1202                     GvMULTI_on(gv);
1203                     hv_magic(hv, NULL, PERL_MAGIC_overload);
1204                 }
1205                 break;
1206             case 'S':
1207                 if (strEQ(name2, "IG")) {
1208                     HV *hv;
1209                     I32 i;
1210                     if (!PL_psig_name) {
1211                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1212                         Newxz(PL_psig_pend, SIG_SIZE, int);
1213                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1214                     } else {
1215                         /* I think that the only way to get here is to re-use an
1216                            embedded perl interpreter, where the previous
1217                            use didn't clean up fully because
1218                            PL_perl_destruct_level was 0. I'm not sure that we
1219                            "support" that, in that I suspect in that scenario
1220                            there are sufficient other garbage values left in the
1221                            interpreter structure that something else will crash
1222                            before we get here. I suspect that this is one of
1223                            those "doctor, it hurts when I do this" bugs.  */
1224                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1225                         Zero(PL_psig_pend, SIG_SIZE, int);
1226                     }
1227                     GvMULTI_on(gv);
1228                     hv = GvHVn(gv);
1229                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1230                     for (i = 1; i < SIG_SIZE; i++) {
1231                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1232                         if (init)
1233                             sv_setsv(*init, &PL_sv_undef);
1234                     }
1235                 }
1236                 break;
1237             case 'V':
1238                 if (strEQ(name2, "ERSION"))
1239                     GvMULTI_on(gv);
1240                 break;
1241             case '\003':        /* $^CHILD_ERROR_NATIVE */
1242                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1243                     goto magicalize;
1244                 break;
1245             case '\005':        /* $^ENCODING */
1246                 if (strEQ(name2, "NCODING"))
1247                     goto magicalize;
1248                 break;
1249             case '\015':        /* $^MATCH */
1250                 if (strEQ(name2, "ATCH"))
1251                     goto magicalize;
1252             case '\017':        /* $^OPEN */
1253                 if (strEQ(name2, "PEN"))
1254                     goto magicalize;
1255                 break;
1256             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1257                 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1258                     goto magicalize;
1259             case '\024':        /* ${^TAINT} */
1260                 if (strEQ(name2, "AINT"))
1261                     goto ro_magicalize;
1262                 break;
1263             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1264                 if (strEQ(name2, "NICODE"))
1265                     goto ro_magicalize;
1266                 if (strEQ(name2, "TF8LOCALE"))
1267                     goto ro_magicalize;
1268                 if (strEQ(name2, "TF8CACHE"))
1269                     goto magicalize;
1270                 break;
1271             case '\027':        /* $^WARNING_BITS */
1272                 if (strEQ(name2, "ARNING_BITS"))
1273                     goto magicalize;
1274                 break;
1275             case '1':
1276             case '2':
1277             case '3':
1278             case '4':
1279             case '5':
1280             case '6':
1281             case '7':
1282             case '8':
1283             case '9':
1284             {
1285                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1286                    this test  */
1287                 /* This snippet is taken from is_gv_magical */
1288                 const char *end = name + len;
1289                 while (--end > name) {
1290                     if (!isDIGIT(*end)) return gv;
1291                 }
1292                 goto magicalize;
1293             }
1294             }
1295         }
1296     } else {
1297         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1298            be case '\0' in this switch statement (ie a default case)  */
1299         switch (*name) {
1300         case '&':
1301         case '`':
1302         case '\'':
1303             if (
1304                 sv_type == SVt_PVAV ||
1305                 sv_type == SVt_PVHV ||
1306                 sv_type == SVt_PVCV ||
1307                 sv_type == SVt_PVFM ||
1308                 sv_type == SVt_PVIO
1309                 ) { break; }
1310             PL_sawampersand = TRUE;
1311             goto magicalize;
1312
1313         case ':':
1314             sv_setpv(GvSVn(gv),PL_chopset);
1315             goto magicalize;
1316
1317         case '?':
1318 #ifdef COMPLEX_STATUS
1319             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1320 #endif
1321             goto magicalize;
1322
1323         case '!':
1324             GvMULTI_on(gv);
1325             /* If %! has been used, automatically load Errno.pm. */
1326
1327             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1328
1329             /* magicalization must be done before require_tie_mod is called */
1330             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1331                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1332
1333             break;
1334         case '-':
1335         case '+':
1336         GvMULTI_on(gv); /* no used once warnings here */
1337         {
1338             AV* const av = GvAVn(gv);
1339             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1340
1341             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1342             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1343             if (avc)
1344                 SvREADONLY_on(GvSVn(gv));
1345             SvREADONLY_on(av);
1346
1347             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1348                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1349
1350             break;
1351         }
1352         case '*':
1353         case '#':
1354             if (sv_type == SVt_PV && ckWARN2_d(WARN_DEPRECATED, WARN_SYNTAX))
1355                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1356                             "$%c is no longer supported", *name);
1357             break;
1358         case '|':
1359             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1360             goto magicalize;
1361
1362         case '\010':    /* $^H */
1363             {
1364                 HV *const hv = GvHVn(gv);
1365                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1366             }
1367             goto magicalize;
1368         case '\023':    /* $^S */
1369         ro_magicalize:
1370             SvREADONLY_on(GvSVn(gv));
1371             /* FALL THROUGH */
1372         case '0':
1373         case '1':
1374         case '2':
1375         case '3':
1376         case '4':
1377         case '5':
1378         case '6':
1379         case '7':
1380         case '8':
1381         case '9':
1382         case '[':
1383         case '^':
1384         case '~':
1385         case '=':
1386         case '%':
1387         case '.':
1388         case '(':
1389         case ')':
1390         case '<':
1391         case '>':
1392         case '\\':
1393         case '/':
1394         case '\001':    /* $^A */
1395         case '\003':    /* $^C */
1396         case '\004':    /* $^D */
1397         case '\005':    /* $^E */
1398         case '\006':    /* $^F */
1399         case '\011':    /* $^I, NOT \t in EBCDIC */
1400         case '\016':    /* $^N */
1401         case '\017':    /* $^O */
1402         case '\020':    /* $^P */
1403         case '\024':    /* $^T */
1404         case '\027':    /* $^W */
1405         magicalize:
1406             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1407             break;
1408
1409         case '\014':    /* $^L */
1410             sv_setpvs(GvSVn(gv),"\f");
1411             PL_formfeed = GvSVn(gv);
1412             break;
1413         case ';':
1414             sv_setpvs(GvSVn(gv),"\034");
1415             break;
1416         case ']':
1417         {
1418             SV * const sv = GvSVn(gv);
1419             if (!sv_derived_from(PL_patchlevel, "version"))
1420                 upg_version(PL_patchlevel, TRUE);
1421             GvSV(gv) = vnumify(PL_patchlevel);
1422             SvREADONLY_on(GvSV(gv));
1423             SvREFCNT_dec(sv);
1424         }
1425         break;
1426         case '\026':    /* $^V */
1427         {
1428             SV * const sv = GvSVn(gv);
1429             GvSV(gv) = new_version(PL_patchlevel);
1430             SvREADONLY_on(GvSV(gv));
1431             SvREFCNT_dec(sv);
1432         }
1433         break;
1434         }
1435     }
1436     return gv;
1437 }
1438
1439 void
1440 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1441 {
1442     const char *name;
1443     STRLEN namelen;
1444     const HV * const hv = GvSTASH(gv);
1445
1446     PERL_ARGS_ASSERT_GV_FULLNAME4;
1447
1448     if (!hv) {
1449         SvOK_off(sv);
1450         return;
1451     }
1452     sv_setpv(sv, prefix ? prefix : "");
1453
1454     name = HvNAME_get(hv);
1455     if (name) {
1456         namelen = HvNAMELEN_get(hv);
1457     } else {
1458         name = "__ANON__";
1459         namelen = 8;
1460     }
1461
1462     if (keepmain || strNE(name, "main")) {
1463         sv_catpvn(sv,name,namelen);
1464         sv_catpvs(sv,"::");
1465     }
1466     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1467 }
1468
1469 void
1470 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1471 {
1472     const GV * const egv = GvEGV(gv);
1473
1474     PERL_ARGS_ASSERT_GV_EFULLNAME4;
1475
1476     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1477 }
1478
1479 void
1480 Perl_gv_check(pTHX_ const HV *stash)
1481 {
1482     dVAR;
1483     register I32 i;
1484
1485     PERL_ARGS_ASSERT_GV_CHECK;
1486
1487     if (!HvARRAY(stash))
1488         return;
1489     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1490         const HE *entry;
1491         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1492             register GV *gv;
1493             HV *hv;
1494             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1495                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
1496             {
1497                 if (hv != PL_defstash && hv != stash)
1498                      gv_check(hv);              /* nested package */
1499             }
1500             else if (isALPHA(*HeKEY(entry))) {
1501                 const char *file;
1502                 gv = MUTABLE_GV(HeVAL(entry));
1503                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1504                     continue;
1505                 file = GvFILE(gv);
1506                 CopLINE_set(PL_curcop, GvLINE(gv));
1507 #ifdef USE_ITHREADS
1508                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1509 #else
1510                 CopFILEGV(PL_curcop)
1511                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1512 #endif
1513                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1514                         "Name \"%s::%s\" used only once: possible typo",
1515                         HvNAME_get(stash), GvNAME(gv));
1516             }
1517         }
1518     }
1519 }
1520
1521 GV *
1522 Perl_newGVgen(pTHX_ const char *pack)
1523 {
1524     dVAR;
1525
1526     PERL_ARGS_ASSERT_NEWGVGEN;
1527
1528     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1529                       GV_ADD, SVt_PVGV);
1530 }
1531
1532 /* hopefully this is only called on local symbol table entries */
1533
1534 GP*
1535 Perl_gp_ref(pTHX_ GP *gp)
1536 {
1537     dVAR;
1538     if (!gp)
1539         return NULL;
1540     gp->gp_refcnt++;
1541     if (gp->gp_cv) {
1542         if (gp->gp_cvgen) {
1543             /* If the GP they asked for a reference to contains
1544                a method cache entry, clear it first, so that we
1545                don't infect them with our cached entry */
1546             SvREFCNT_dec(gp->gp_cv);
1547             gp->gp_cv = NULL;
1548             gp->gp_cvgen = 0;
1549         }
1550     }
1551     return gp;
1552 }
1553
1554 void
1555 Perl_gp_free(pTHX_ GV *gv)
1556 {
1557     dVAR;
1558     GP* gp;
1559
1560     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1561         return;
1562     if (gp->gp_refcnt == 0) {
1563         if (ckWARN_d(WARN_INTERNAL))
1564             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1565                         "Attempt to free unreferenced glob pointers"
1566                         pTHX__FORMAT pTHX__VALUE);
1567         return;
1568     }
1569     if (--gp->gp_refcnt > 0) {
1570         if (gp->gp_egv == gv)
1571             gp->gp_egv = 0;
1572         GvGP(gv) = 0;
1573         return;
1574     }
1575
1576     if (gp->gp_file_hek)
1577         unshare_hek(gp->gp_file_hek);
1578     SvREFCNT_dec(gp->gp_sv);
1579     SvREFCNT_dec(gp->gp_av);
1580     /* FIXME - another reference loop GV -> symtab -> GV ?
1581        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1582     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1583         const char *hvname = HvNAME_get(gp->gp_hv);
1584         if (PL_stashcache && hvname)
1585             (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1586                       G_DISCARD);
1587         SvREFCNT_dec(gp->gp_hv);
1588     }
1589     SvREFCNT_dec(gp->gp_io);
1590     SvREFCNT_dec(gp->gp_cv);
1591     SvREFCNT_dec(gp->gp_form);
1592
1593     Safefree(gp);
1594     GvGP(gv) = 0;
1595 }
1596
1597 int
1598 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1599 {
1600     AMT * const amtp = (AMT*)mg->mg_ptr;
1601     PERL_UNUSED_ARG(sv);
1602
1603     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1604
1605     if (amtp && AMT_AMAGIC(amtp)) {
1606         int i;
1607         for (i = 1; i < NofAMmeth; i++) {
1608             CV * const cv = amtp->table[i];
1609             if (cv) {
1610                 SvREFCNT_dec(MUTABLE_SV(cv));
1611                 amtp->table[i] = NULL;
1612             }
1613         }
1614     }
1615  return 0;
1616 }
1617
1618 /* Updates and caches the CV's */
1619 /* Returns:
1620  * 1 on success and there is some overload
1621  * 0 if there is no overload
1622  * -1 if some error occurred and it couldn't croak
1623  */
1624
1625 int
1626 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
1627 {
1628   dVAR;
1629   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1630   AMT amt;
1631   const struct mro_meta* stash_meta = HvMROMETA(stash);
1632   U32 newgen;
1633
1634   PERL_ARGS_ASSERT_GV_AMUPDATE;
1635
1636   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1637   if (mg) {
1638       const AMT * const amtp = (AMT*)mg->mg_ptr;
1639       if (amtp->was_ok_am == PL_amagic_generation
1640           && amtp->was_ok_sub == newgen) {
1641           return AMT_OVERLOADED(amtp) ? 1 : 0;
1642       }
1643       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
1644   }
1645
1646   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1647
1648   Zero(&amt,1,AMT);
1649   amt.was_ok_am = PL_amagic_generation;
1650   amt.was_ok_sub = newgen;
1651   amt.fallback = AMGfallNO;
1652   amt.flags = 0;
1653
1654   {
1655     int filled = 0, have_ovl = 0;
1656     int i, lim = 1;
1657
1658     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1659
1660     /* Try to find via inheritance. */
1661     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1662     SV * const sv = gv ? GvSV(gv) : NULL;
1663     CV* cv;
1664
1665     if (!gv)
1666         lim = DESTROY_amg;              /* Skip overloading entries. */
1667 #ifdef PERL_DONT_CREATE_GVSV
1668     else if (!sv) {
1669         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1670     }
1671 #endif
1672     else if (SvTRUE(sv))
1673         amt.fallback=AMGfallYES;
1674     else if (SvOK(sv))
1675         amt.fallback=AMGfallNEVER;
1676
1677     for (i = 1; i < lim; i++)
1678         amt.table[i] = NULL;
1679     for (; i < NofAMmeth; i++) {
1680         const char * const cooky = PL_AMG_names[i];
1681         /* Human-readable form, for debugging: */
1682         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1683         const STRLEN l = PL_AMG_namelens[i];
1684
1685         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1686                      cp, HvNAME_get(stash)) );
1687         /* don't fill the cache while looking up!
1688            Creation of inheritance stubs in intermediate packages may
1689            conflict with the logic of runtime method substitution.
1690            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1691            then we could have created stubs for "(+0" in A and C too.
1692            But if B overloads "bool", we may want to use it for
1693            numifying instead of C's "+0". */
1694         if (i >= DESTROY_amg)
1695             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1696         else                            /* Autoload taken care of below */
1697             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1698         cv = 0;
1699         if (gv && (cv = GvCV(gv))) {
1700             const char *hvname;
1701             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1702                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1703                 /* This is a hack to support autoloading..., while
1704                    knowing *which* methods were declared as overloaded. */
1705                 /* GvSV contains the name of the method. */
1706                 GV *ngv = NULL;
1707                 SV *gvsv = GvSV(gv);
1708
1709                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1710                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1711                              (void*)GvSV(gv), cp, hvname) );
1712                 if (!gvsv || !SvPOK(gvsv)
1713                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1714                                                        FALSE)))
1715                 {
1716                     /* Can be an import stub (created by "can"). */
1717                     if (destructing) {
1718                         return -1;
1719                     }
1720                     else {
1721                         const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1722                         Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1723                                     "in package \"%.256s\"",
1724                                    (GvCVGEN(gv) ? "Stub found while resolving"
1725                                     : "Can't resolve"),
1726                                    name, cp, hvname);
1727                     }
1728                 }
1729                 cv = GvCV(gv = ngv);
1730             }
1731             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1732                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1733                          GvNAME(CvGV(cv))) );
1734             filled = 1;
1735             if (i < DESTROY_amg)
1736                 have_ovl = 1;
1737         } else if (gv) {                /* Autoloaded... */
1738             cv = MUTABLE_CV(gv);
1739             filled = 1;
1740         }
1741         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
1742     }
1743     if (filled) {
1744       AMT_AMAGIC_on(&amt);
1745       if (have_ovl)
1746           AMT_OVERLOADED_on(&amt);
1747       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
1748                                                 (char*)&amt, sizeof(AMT));
1749       return have_ovl;
1750     }
1751   }
1752   /* Here we have no table: */
1753   /* no_table: */
1754   AMT_AMAGIC_off(&amt);
1755   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
1756                                                 (char*)&amt, sizeof(AMTS));
1757   return 0;
1758 }
1759
1760
1761 CV*
1762 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1763 {
1764     dVAR;
1765     MAGIC *mg;
1766     AMT *amtp;
1767     U32 newgen;
1768     struct mro_meta* stash_meta;
1769
1770     if (!stash || !HvNAME_get(stash))
1771         return NULL;
1772
1773     stash_meta = HvMROMETA(stash);
1774     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1775
1776     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1777     if (!mg) {
1778       do_update:
1779         /* If we're looking up a destructor to invoke, we must avoid
1780          * that Gv_AMupdate croaks, because we might be dying already */
1781         if (Gv_AMupdate(stash, id == DESTROY_amg) == -1) {
1782             /* and if it didn't found a destructor, we fall back
1783              * to a simpler method that will only look for the
1784              * destructor instead of the whole magic */
1785             if (id == DESTROY_amg) {
1786                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
1787                 if (gv)
1788                     return GvCV(gv);
1789             }
1790             return NULL;
1791         }
1792         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1793     }
1794     assert(mg);
1795     amtp = (AMT*)mg->mg_ptr;
1796     if ( amtp->was_ok_am != PL_amagic_generation
1797          || amtp->was_ok_sub != newgen )
1798         goto do_update;
1799     if (AMT_AMAGIC(amtp)) {
1800         CV * const ret = amtp->table[id];
1801         if (ret && isGV(ret)) {         /* Autoloading stab */
1802             /* Passing it through may have resulted in a warning
1803                "Inherited AUTOLOAD for a non-method deprecated", since
1804                our caller is going through a function call, not a method call.
1805                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1806             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1807
1808             if (gv && GvCV(gv))
1809                 return GvCV(gv);
1810         }
1811         return ret;
1812     }
1813
1814     return NULL;
1815 }
1816
1817
1818 SV*
1819 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1820 {
1821   dVAR;
1822   MAGIC *mg;
1823   CV *cv=NULL;
1824   CV **cvp=NULL, **ocvp=NULL;
1825   AMT *amtp=NULL, *oamtp=NULL;
1826   int off = 0, off1, lr = 0, notfound = 0;
1827   int postpr = 0, force_cpy = 0;
1828   int assign = AMGf_assign & flags;
1829   const int assignshift = assign ? 1 : 0;
1830 #ifdef DEBUGGING
1831   int fl=0;
1832 #endif
1833   HV* stash=NULL;
1834
1835   PERL_ARGS_ASSERT_AMAGIC_CALL;
1836
1837   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
1838       SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
1839                                               0, "overloading", 11, 0, 0);
1840
1841       if ( !lex_mask || !SvOK(lex_mask) )
1842           /* overloading lexically disabled */
1843           return NULL;
1844       else if ( lex_mask && SvPOK(lex_mask) ) {
1845           /* we have an entry in the hints hash, check if method has been
1846            * masked by overloading.pm */
1847           STRLEN len;
1848           const int offset = method / 8;
1849           const int bit    = method % 8;
1850           char *pv = SvPV(lex_mask, len);
1851
1852           /* Bit set, so this overloading operator is disabled */
1853           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
1854               return NULL;
1855       }
1856   }
1857
1858   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1859       && (stash = SvSTASH(SvRV(left)))
1860       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
1861       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1862                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1863                         : NULL))
1864       && ((cv = cvp[off=method+assignshift])
1865           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1866                                                           * usual method */
1867                   (
1868 #ifdef DEBUGGING
1869                    fl = 1,
1870 #endif
1871                    cv = cvp[off=method])))) {
1872     lr = -1;                    /* Call method for left argument */
1873   } else {
1874     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1875       int logic;
1876
1877       /* look for substituted methods */
1878       /* In all the covered cases we should be called with assign==0. */
1879          switch (method) {
1880          case inc_amg:
1881            force_cpy = 1;
1882            if ((cv = cvp[off=add_ass_amg])
1883                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1884              right = &PL_sv_yes; lr = -1; assign = 1;
1885            }
1886            break;
1887          case dec_amg:
1888            force_cpy = 1;
1889            if ((cv = cvp[off = subtr_ass_amg])
1890                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1891              right = &PL_sv_yes; lr = -1; assign = 1;
1892            }
1893            break;
1894          case bool__amg:
1895            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1896            break;
1897          case numer_amg:
1898            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1899            break;
1900          case string_amg:
1901            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1902            break;
1903          case not_amg:
1904            (void)((cv = cvp[off=bool__amg])
1905                   || (cv = cvp[off=numer_amg])
1906                   || (cv = cvp[off=string_amg]));
1907            postpr = 1;
1908            break;
1909          case copy_amg:
1910            {
1911              /*
1912                   * SV* ref causes confusion with the interpreter variable of
1913                   * the same name
1914                   */
1915              SV* const tmpRef=SvRV(left);
1916              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1917                 /*
1918                  * Just to be extra cautious.  Maybe in some
1919                  * additional cases sv_setsv is safe, too.
1920                  */
1921                 SV* const newref = newSVsv(tmpRef);
1922                 SvOBJECT_on(newref);
1923                 /* As a bit of a source compatibility hack, SvAMAGIC() and
1924                    friends dereference an RV, to behave the same was as when
1925                    overloading was stored on the reference, not the referant.
1926                    Hence we can't use SvAMAGIC_on()
1927                 */
1928                 SvFLAGS(newref) |= SVf_AMAGIC;
1929                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
1930                 return newref;
1931              }
1932            }
1933            break;
1934          case abs_amg:
1935            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1936                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1937              SV* const nullsv=sv_2mortal(newSViv(0));
1938              if (off1==lt_amg) {
1939                SV* const lessp = amagic_call(left,nullsv,
1940                                        lt_amg,AMGf_noright);
1941                logic = SvTRUE(lessp);
1942              } else {
1943                SV* const lessp = amagic_call(left,nullsv,
1944                                        ncmp_amg,AMGf_noright);
1945                logic = (SvNV(lessp) < 0);
1946              }
1947              if (logic) {
1948                if (off==subtr_amg) {
1949                  right = left;
1950                  left = nullsv;
1951                  lr = 1;
1952                }
1953              } else {
1954                return left;
1955              }
1956            }
1957            break;
1958          case neg_amg:
1959            if ((cv = cvp[off=subtr_amg])) {
1960              right = left;
1961              left = sv_2mortal(newSViv(0));
1962              lr = 1;
1963            }
1964            break;
1965          case int_amg:
1966          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1967          case ftest_amg:                /* XXXX Eventually should do to_gv. */
1968              /* FAIL safe */
1969              return NULL;       /* Delegate operation to standard mechanisms. */
1970              break;
1971          case to_sv_amg:
1972          case to_av_amg:
1973          case to_hv_amg:
1974          case to_gv_amg:
1975          case to_cv_amg:
1976              /* FAIL safe */
1977              return left;       /* Delegate operation to standard mechanisms. */
1978              break;
1979          default:
1980            goto not_found;
1981          }
1982          if (!cv) goto not_found;
1983     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1984                && (stash = SvSTASH(SvRV(right)))
1985                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
1986                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1987                           ? (amtp = (AMT*)mg->mg_ptr)->table
1988                           : NULL))
1989                && (cv = cvp[off=method])) { /* Method for right
1990                                              * argument found */
1991       lr=1;
1992     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1993                  && (cvp=ocvp) && (lr = -1))
1994                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1995                && !(flags & AMGf_unary)) {
1996                                 /* We look for substitution for
1997                                  * comparison operations and
1998                                  * concatenation */
1999       if (method==concat_amg || method==concat_ass_amg
2000           || method==repeat_amg || method==repeat_ass_amg) {
2001         return NULL;            /* Delegate operation to string conversion */
2002       }
2003       off = -1;
2004       switch (method) {
2005          case lt_amg:
2006          case le_amg:
2007          case gt_amg:
2008          case ge_amg:
2009          case eq_amg:
2010          case ne_amg:
2011            postpr = 1; off=ncmp_amg; break;
2012          case slt_amg:
2013          case sle_amg:
2014          case sgt_amg:
2015          case sge_amg:
2016          case seq_amg:
2017          case sne_amg:
2018            postpr = 1; off=scmp_amg; break;
2019          }
2020       if (off != -1) cv = cvp[off];
2021       if (!cv) {
2022         goto not_found;
2023       }
2024     } else {
2025     not_found:                  /* No method found, either report or croak */
2026       switch (method) {
2027          case lt_amg:
2028          case le_amg:
2029          case gt_amg:
2030          case ge_amg:
2031          case eq_amg:
2032          case ne_amg:
2033          case slt_amg:
2034          case sle_amg:
2035          case sgt_amg:
2036          case sge_amg:
2037          case seq_amg:
2038          case sne_amg:
2039            postpr = 0; break;
2040          case to_sv_amg:
2041          case to_av_amg:
2042          case to_hv_amg:
2043          case to_gv_amg:
2044          case to_cv_amg:
2045              /* FAIL safe */
2046              return left;       /* Delegate operation to standard mechanisms. */
2047              break;
2048       }
2049       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2050         notfound = 1; lr = -1;
2051       } else if (cvp && (cv=cvp[nomethod_amg])) {
2052         notfound = 1; lr = 1;
2053       } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
2054         /* Skip generating the "no method found" message.  */
2055         return NULL;
2056       } else {
2057         SV *msg;
2058         if (off==-1) off=method;
2059         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2060                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
2061                       AMG_id2name(method + assignshift),
2062                       (flags & AMGf_unary ? " " : "\n\tleft "),
2063                       SvAMAGIC(left)?
2064                         "in overloaded package ":
2065                         "has no overloaded magic",
2066                       SvAMAGIC(left)?
2067                         HvNAME_get(SvSTASH(SvRV(left))):
2068                         "",
2069                       SvAMAGIC(right)?
2070                         ",\n\tright argument in overloaded package ":
2071                         (flags & AMGf_unary
2072                          ? ""
2073                          : ",\n\tright argument has no overloaded magic"),
2074                       SvAMAGIC(right)?
2075                         HvNAME_get(SvSTASH(SvRV(right))):
2076                         ""));
2077         if (amtp && amtp->fallback >= AMGfallYES) {
2078           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2079         } else {
2080           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2081         }
2082         return NULL;
2083       }
2084       force_cpy = force_cpy || assign;
2085     }
2086   }
2087 #ifdef DEBUGGING
2088   if (!notfound) {
2089     DEBUG_o(Perl_deb(aTHX_
2090                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2091                      AMG_id2name(off),
2092                      method+assignshift==off? "" :
2093                      " (initially \"",
2094                      method+assignshift==off? "" :
2095                      AMG_id2name(method+assignshift),
2096                      method+assignshift==off? "" : "\")",
2097                      flags & AMGf_unary? "" :
2098                      lr==1 ? " for right argument": " for left argument",
2099                      flags & AMGf_unary? " for argument" : "",
2100                      stash ? HvNAME_get(stash) : "null",
2101                      fl? ",\n\tassignment variant used": "") );
2102   }
2103 #endif
2104     /* Since we use shallow copy during assignment, we need
2105      * to dublicate the contents, probably calling user-supplied
2106      * version of copy operator
2107      */
2108     /* We need to copy in following cases:
2109      * a) Assignment form was called.
2110      *          assignshift==1,  assign==T, method + 1 == off
2111      * b) Increment or decrement, called directly.
2112      *          assignshift==0,  assign==0, method + 0 == off
2113      * c) Increment or decrement, translated to assignment add/subtr.
2114      *          assignshift==0,  assign==T,
2115      *          force_cpy == T
2116      * d) Increment or decrement, translated to nomethod.
2117      *          assignshift==0,  assign==0,
2118      *          force_cpy == T
2119      * e) Assignment form translated to nomethod.
2120      *          assignshift==1,  assign==T, method + 1 != off
2121      *          force_cpy == T
2122      */
2123     /*  off is method, method+assignshift, or a result of opcode substitution.
2124      *  In the latter case assignshift==0, so only notfound case is important.
2125      */
2126   if (( (method + assignshift == off)
2127         && (assign || (method == inc_amg) || (method == dec_amg)))
2128       || force_cpy)
2129     RvDEEPCP(left);
2130   {
2131     dSP;
2132     BINOP myop;
2133     SV* res;
2134     const bool oldcatch = CATCH_GET;
2135
2136     CATCH_SET(TRUE);
2137     Zero(&myop, 1, BINOP);
2138     myop.op_last = (OP *) &myop;
2139     myop.op_next = NULL;
2140     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2141
2142     PUSHSTACKi(PERLSI_OVERLOAD);
2143     ENTER;
2144     SAVEOP();
2145     PL_op = (OP *) &myop;
2146     if (PERLDB_SUB && PL_curstash != PL_debstash)
2147         PL_op->op_private |= OPpENTERSUB_DB;
2148     PUTBACK;
2149     pp_pushmark();
2150
2151     EXTEND(SP, notfound + 5);
2152     PUSHs(lr>0? right: left);
2153     PUSHs(lr>0? left: right);
2154     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2155     if (notfound) {
2156       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2157                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2158     }
2159     PUSHs(MUTABLE_SV(cv));
2160     PUTBACK;
2161
2162     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2163       CALLRUNOPS(aTHX);
2164     LEAVE;
2165     SPAGAIN;
2166
2167     res=POPs;
2168     PUTBACK;
2169     POPSTACK;
2170     CATCH_SET(oldcatch);
2171
2172     if (postpr) {
2173       int ans;
2174       switch (method) {
2175       case le_amg:
2176       case sle_amg:
2177         ans=SvIV(res)<=0; break;
2178       case lt_amg:
2179       case slt_amg:
2180         ans=SvIV(res)<0; break;
2181       case ge_amg:
2182       case sge_amg:
2183         ans=SvIV(res)>=0; break;
2184       case gt_amg:
2185       case sgt_amg:
2186         ans=SvIV(res)>0; break;
2187       case eq_amg:
2188       case seq_amg:
2189         ans=SvIV(res)==0; break;
2190       case ne_amg:
2191       case sne_amg:
2192         ans=SvIV(res)!=0; break;
2193       case inc_amg:
2194       case dec_amg:
2195         SvSetSV(left,res); return left;
2196       case not_amg:
2197         ans=!SvTRUE(res); break;
2198       default:
2199         ans=0; break;
2200       }
2201       return boolSV(ans);
2202     } else if (method==copy_amg) {
2203       if (!SvROK(res)) {
2204         Perl_croak(aTHX_ "Copy method did not return a reference");
2205       }
2206       return SvREFCNT_inc(SvRV(res));
2207     } else {
2208       return res;
2209     }
2210   }
2211 }
2212
2213 /*
2214 =for apidoc is_gv_magical_sv
2215
2216 Returns C<TRUE> if given the name of a magical GV.
2217
2218 Currently only useful internally when determining if a GV should be
2219 created even in rvalue contexts.
2220
2221 C<flags> is not used at present but available for future extension to
2222 allow selecting particular classes of magical variable.
2223
2224 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2225 This assumption is met by all callers within the perl core, which all pass
2226 pointers returned by SvPV.
2227
2228 =cut
2229 */
2230
2231 bool
2232 Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
2233 {
2234     STRLEN len;
2235     const char *const name = SvPV_const(name_sv, len);
2236
2237     PERL_UNUSED_ARG(flags);
2238     PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
2239
2240     if (len > 1) {
2241         const char * const name1 = name + 1;
2242         switch (*name) {
2243         case 'I':
2244             if (len == 3 && name[1] == 'S' && name[2] == 'A')
2245                 goto yes;
2246             break;
2247         case 'O':
2248             if (len == 8 && strEQ(name1, "VERLOAD"))
2249                 goto yes;
2250             break;
2251         case 'S':
2252             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2253                 goto yes;
2254             break;
2255             /* Using ${^...} variables is likely to be sufficiently rare that
2256                it seems sensible to avoid the space hit of also checking the
2257                length.  */
2258         case '\017':   /* ${^OPEN} */
2259             if (strEQ(name1, "PEN"))
2260                 goto yes;
2261             break;
2262         case '\024':   /* ${^TAINT} */
2263             if (strEQ(name1, "AINT"))
2264                 goto yes;
2265             break;
2266         case '\025':    /* ${^UNICODE} */
2267             if (strEQ(name1, "NICODE"))
2268                 goto yes;
2269             if (strEQ(name1, "TF8LOCALE"))
2270                 goto yes;
2271             break;
2272         case '\027':   /* ${^WARNING_BITS} */
2273             if (strEQ(name1, "ARNING_BITS"))
2274                 goto yes;
2275             break;
2276         case '1':
2277         case '2':
2278         case '3':
2279         case '4':
2280         case '5':
2281         case '6':
2282         case '7':
2283         case '8':
2284         case '9':
2285         {
2286             const char *end = name + len;
2287             while (--end > name) {
2288                 if (!isDIGIT(*end))
2289                     return FALSE;
2290             }
2291             goto yes;
2292         }
2293         }
2294     } else {
2295         /* Because we're already assuming that name is NUL terminated
2296            below, we can treat an empty name as "\0"  */
2297         switch (*name) {
2298         case '&':
2299         case '`':
2300         case '\'':
2301         case ':':
2302         case '?':
2303         case '!':
2304         case '-':
2305         case '#':
2306         case '[':
2307         case '^':
2308         case '~':
2309         case '=':
2310         case '%':
2311         case '.':
2312         case '(':
2313         case ')':
2314         case '<':
2315         case '>':
2316         case '\\':
2317         case '/':
2318         case '|':
2319         case '+':
2320         case ';':
2321         case ']':
2322         case '\001':   /* $^A */
2323         case '\003':   /* $^C */
2324         case '\004':   /* $^D */
2325         case '\005':   /* $^E */
2326         case '\006':   /* $^F */
2327         case '\010':   /* $^H */
2328         case '\011':   /* $^I, NOT \t in EBCDIC */
2329         case '\014':   /* $^L */
2330         case '\016':   /* $^N */
2331         case '\017':   /* $^O */
2332         case '\020':   /* $^P */
2333         case '\023':   /* $^S */
2334         case '\024':   /* $^T */
2335         case '\026':   /* $^V */
2336         case '\027':   /* $^W */
2337         case '1':
2338         case '2':
2339         case '3':
2340         case '4':
2341         case '5':
2342         case '6':
2343         case '7':
2344         case '8':
2345         case '9':
2346         yes:
2347             return TRUE;
2348         default:
2349             break;
2350         }
2351     }
2352     return FALSE;
2353 }
2354
2355 void
2356 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2357 {
2358     dVAR;
2359     U32 hash;
2360
2361     PERL_ARGS_ASSERT_GV_NAME_SET;
2362     PERL_UNUSED_ARG(flags);
2363
2364     if (len > I32_MAX)
2365         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2366
2367     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2368         unshare_hek(GvNAME_HEK(gv));
2369     }
2370
2371     PERL_HASH(hash, name, len);
2372     GvNAME_HEK(gv) = share_hek(name, len, hash);
2373 }
2374
2375 /*
2376  * Local variables:
2377  * c-indentation-style: bsd
2378  * c-basic-offset: 4
2379  * indent-tabs-mode: t
2380  * End:
2381  *
2382  * ex: set ts=8 sts=4 sw=4 noet:
2383  */