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