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