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