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         Perl_croak(aTHX_ "Bad symbol for %s", fh);
 103     }
 104
 105     if (!GvIOp(gv)) {
 106         GvIOp(gv) = newIO();
 107     }
 108     return gv;
 109 }
 110
 111 GV *
 112 Perl_gv_fetchfile(pTHX_ const char *name)
 113 {
 114     PERL_ARGS_ASSERT_GV_FETCHFILE;
 115     return gv_fetchfile_flags(name, strlen(name), 0);
 116 }
 117
 118 GV *
 119 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
 120                         const U32 flags)
 121 {
 122     dVAR;
 123     char smallbuf[128];
 124     char *tmpbuf;
 125     const STRLEN tmplen = namelen + 2;
 126     GV *gv;
 127
 128     PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
 129     PERL_UNUSED_ARG(flags);
 130
 131     if (!PL_defstash)
 132         return NULL;
 133
 134     if (tmplen <= sizeof smallbuf)
 135         tmpbuf = smallbuf;
 136     else
 137         Newx(tmpbuf, tmplen, char);
 138     /* This is where the debugger's %{"::_<$filename"} hash is created */
 139     tmpbuf[0] = '_';
 140     tmpbuf[1] = '<';
 141     memcpy(tmpbuf + 2, name, namelen);
 142     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
 143     if (!isGV(gv)) {
 144         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
 145 #ifdef PERL_DONT_CREATE_GVSV
 146         GvSV(gv) = newSVpvn(name, namelen);
 147 #else
 148         sv_setpvn(GvSV(gv), name, namelen);
 149 #endif
 150         if (PERLDB_LINE || PERLDB_SAVESRC)
 151             hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
 152     }
 153     if (tmpbuf != smallbuf)
 154         Safefree(tmpbuf);
 155     return gv;
 156 }
 157
 158 /*
 159 =for apidoc gv_const_sv
 160
 161 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
 162 inlining, or C<gv> is a placeholder reference that would be promoted to such
 163 a typeglob, then returns the value returned by the sub.  Otherwise, returns
 164 NULL.
 165
 166 =cut
 167 */
 168
 169 SV *
 170 Perl_gv_const_sv(pTHX_ GV *gv)
 171 {
 172     PERL_ARGS_ASSERT_GV_CONST_SV;
 173
 174     if (SvTYPE(gv) == SVt_PVGV)
 175         return cv_const_sv(GvCVu(gv));
 176     return SvROK(gv) ? SvRV(gv) : NULL;
 177 }
 178
 179 GP *
 180 Perl_newGP(pTHX_ GV *const gv)
 181 {
 182     GP *gp;
 183     U32 hash;
 184 #ifdef USE_ITHREADS
 185     const char *const file
 186         = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
 187     const STRLEN len = strlen(file);
 188 #else
 189     SV *const temp_sv = CopFILESV(PL_curcop);
 190     const char *file;
 191     STRLEN len;
 192
 193     PERL_ARGS_ASSERT_NEWGP;
 194
 195     if (temp_sv) {
 196         file = SvPVX(temp_sv);
 197         len = SvCUR(temp_sv);
 198     } else {
 199         file = "";
 200         len = 0;
 201     }
 202 #endif
 203
 204     PERL_HASH(hash, file, len);
 205
 206     Newxz(gp, 1, GP);
 207
 208 #ifndef PERL_DONT_CREATE_GVSV
 209     gp->gp_sv = newSV(0);
 210 #endif
 211
 212     gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
 213     /* XXX Ideally this cast would be replaced with a change to const char*
 214        in the struct.  */
 215     gp->gp_file_hek = share_hek(file, len, hash);
 216     gp->gp_egv = gv;
 217     gp->gp_refcnt = 1;
 218
 219     return gp;
 220 }
 221
 222 void
 223 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 224 {
 225     dVAR;
 226     const U32 old_type = SvTYPE(gv);
 227     const bool doproto = old_type > SVt_NULL;
 228     char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
 229     const STRLEN protolen = proto ? SvCUR(gv) : 0;
 230     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
 231     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
 232
 233     PERL_ARGS_ASSERT_GV_INIT;
 234     assert (!(proto && has_constant));
 235
 236     if (has_constant) {
 237         /* The constant has to be a simple scalar type.  */
 238         switch (SvTYPE(has_constant)) {
 239         case SVt_PVAV:
 240         case SVt_PVHV:
 241         case SVt_PVCV:
 242         case SVt_PVFM:
 243         case SVt_PVIO:
 244             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
 245                        sv_reftype(has_constant, 0));
 246         default: NOOP;
 247         }
 248         SvRV_set(gv, NULL);
 249         SvROK_off(gv);
 250     }
 251
 252
 253     if (old_type < SVt_PVGV) {
 254         if (old_type >= SVt_PV)
 255             SvCUR_set(gv, 0);
 256         sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
 257     }
 258     if (SvLEN(gv)) {
 259         if (proto) {
 260             SvPV_set(gv, NULL);
 261             SvLEN_set(gv, 0);
 262             SvPOK_off(gv);
 263         } else
 264             Safefree(SvPVX_mutable(gv));
 265     }
 266     SvIOK_off(gv);
 267     isGV_with_GP_on(gv);
 268
 269     GvGP(gv) = Perl_newGP(aTHX_ gv);
 270     GvSTASH(gv) = stash;
 271     if (stash)
 272         Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
 273     gv_name_set(gv, name, len, GV_ADD);
 274     if (multi || doproto)              /* doproto means it _was_ mentioned */
 275         GvMULTI_on(gv);
 276     if (doproto) {                      /* Replicate part of newSUB here. */
 277         ENTER;
 278         if (has_constant) {
 279             /* newCONSTSUB takes ownership of the reference from us.  */
 280             GvCV(gv) = newCONSTSUB(stash, name, has_constant);
 281             /* If this reference was a copy of another, then the subroutine
 282                must have been "imported", by a Perl space assignment to a GV
 283                from a reference to CV.  */
 284             if (exported_constant)
 285                 GvIMPORTED_CV_on(gv);
 286         } else {
 287             (void) start_subparse(0,0); /* Create empty CV in compcv. */
 288             GvCV(gv) = PL_compcv;
 289         }
 290         LEAVE;
 291
 292         mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
 293         CvGV(GvCV(gv)) = gv;
 294         CvFILE_set_from_cop(GvCV(gv), PL_curcop);
 295         CvSTASH(GvCV(gv)) = PL_curstash;
 296         if (proto) {
 297             sv_usepvn_flags(MUTABLE_SV(GvCV(gv)), proto, protolen,
 298                             SV_HAS_TRAILING_NUL);
 299         }
 300     }
 301 }
 302
 303 STATIC void
 304 S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type)
 305 {
 306     PERL_ARGS_ASSERT_GV_INIT_SV;
 307
 308     switch (sv_type) {
 309     case SVt_PVIO:
 310         (void)GvIOn(gv);
 311         break;
 312     case SVt_PVAV:
 313         (void)GvAVn(gv);
 314         break;
 315     case SVt_PVHV:
 316         (void)GvHVn(gv);
 317         break;
 318 #ifdef PERL_DONT_CREATE_GVSV
 319     case SVt_NULL:
 320     case SVt_PVCV:
 321     case SVt_PVFM:
 322     case SVt_PVGV:
 323         break;
 324     default:
 325         if(GvSVn(gv)) {
 326             /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
 327                If we just cast GvSVn(gv) to void, it ignores evaluating it for
 328                its side effect */
 329         }
 330 #endif
 331     }
 332 }
 333
 334 /*
 335 =for apidoc gv_fetchmeth
 336
 337 Returns the glob with the given C<name> and a defined subroutine or
 338 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
 339 accessible via @ISA and UNIVERSAL::.
 340
 341 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 342 side-effect creates a glob with the given C<name> in the given C<stash>
 343 which in the case of success contains an alias for the subroutine, and sets
 344 up caching info for this glob.
 345
 346 This function grants C<"SUPER"> token as a postfix of the stash name. The
 347 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 348 visible to Perl code.  So when calling C<call_sv>, you should not use
 349 the GV directly; instead, you should use the method's CV, which can be
 350 obtained from the GV with the C<GvCV> macro.
 351
 352 =cut
 353 */
 354
 355 /* NOTE: No support for tied ISA */
 356
 357 GV *
 358 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 359 {
 360     dVAR;
 361     GV** gvp;
 362     AV* linear_av;
 363     SV** linear_svp;
 364     SV* linear_sv;
 365     HV* cstash;
 366     GV* candidate = NULL;
 367     CV* cand_cv = NULL;
 368     CV* old_cv;
 369     GV* topgv = NULL;
 370     const char *hvname;
 371     I32 create = (level >= 0) ? 1 : 0;
 372     I32 items;
 373     STRLEN packlen;
 374     U32 topgen_cmp;
 375
 376     PERL_ARGS_ASSERT_GV_FETCHMETH;
 377
 378     /* UNIVERSAL methods should be callable without a stash */
 379     if (!stash) {
 380         create = 0;  /* probably appropriate */
 381         if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
 382             return 0;
 383     }
 384
 385     assert(stash);
 386
 387     hvname = HvNAME_get(stash);
 388     if (!hvname)
 389       Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 390
 391     assert(hvname);
 392     assert(name);
 393
 394     DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
 395
 396     topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
 397
 398     /* check locally for a real method or a cache entry */
 399     gvp = (GV**)hv_fetch(stash, name, len, create);
 400     if(gvp) {
 401         topgv = *gvp;
 402         assert(topgv);
 403         if (SvTYPE(topgv) != SVt_PVGV)
 404             gv_init(topgv, stash, name, len, TRUE);
 405         if ((cand_cv = GvCV(topgv))) {
 406             /* If genuine method or valid cache entry, use it */
 407             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
 408                 return topgv;
 409             }
 410             else {
 411                 /* stale cache entry, junk it and move on */
 412                 SvREFCNT_dec(cand_cv);
 413                 GvCV(topgv) = cand_cv = NULL;
 414                 GvCVGEN(topgv) = 0;
 415             }
 416         }
 417         else if (GvCVGEN(topgv) == topgen_cmp) {
 418             /* cache indicates no such method definitively */
 419             return 0;
 420         }
 421     }
 422
 423     packlen = HvNAMELEN_get(stash);
 424     if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
 425         HV* basestash;
 426         packlen -= 7;
 427         basestash = gv_stashpvn(hvname, packlen, GV_ADD);
 428         linear_av = mro_get_linear_isa(basestash);
 429     }
 430     else {
 431         linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
 432     }
 433
 434     linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
 435     items = AvFILLp(linear_av); /* no +1, to skip over self */
 436     while (items--) {
 437         linear_sv = *linear_svp++;
 438         assert(linear_sv);
 439         cstash = gv_stashsv(linear_sv, 0);
 440
 441         if (!cstash) {
 442             if (ckWARN(WARN_SYNTAX))
 443                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
 444                     SVfARG(linear_sv), hvname);
 445             continue;
 446         }
 447
 448         assert(cstash);
 449
 450         gvp = (GV**)hv_fetch(cstash, name, len, 0);
 451         if (!gvp) continue;
 452         candidate = *gvp;
 453         assert(candidate);
 454         if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
 455         if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 456             /*
 457              * Found real method, cache method in topgv if:
 458              *  1. topgv has no synonyms (else inheritance crosses wires)
 459              *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 460              */
 461             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 462                   if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
 463                   SvREFCNT_inc_simple_void_NN(cand_cv);
 464                   GvCV(topgv) = cand_cv;
 465                   GvCVGEN(topgv) = topgen_cmp;
 466             }
 467             return candidate;
 468         }
 469     }
 470
 471     /* Check UNIVERSAL without caching */
 472     if(level == 0 || level == -1) {
 473         candidate = gv_fetchmeth(NULL, name, len, 1);
 474         if(candidate) {
 475             cand_cv = GvCV(candidate);
 476             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 477                   if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
 478                   SvREFCNT_inc_simple_void_NN(cand_cv);
 479                   GvCV(topgv) = cand_cv;
 480                   GvCVGEN(topgv) = topgen_cmp;
 481             }
 482             return candidate;
 483         }
 484     }
 485
 486     if (topgv && GvREFCNT(topgv) == 1) {
 487         /* cache the fact that the method is not defined */
 488         GvCVGEN(topgv) = topgen_cmp;
 489     }
 490
 491     return 0;
 492 }
 493
 494 /*
 495 =for apidoc gv_fetchmeth_autoload
 496
 497 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
 498 Returns a glob for the subroutine.
 499
 500 For an autoloaded subroutine without a GV, will create a GV even
 501 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
 502 of the result may be zero.
 503
 504 =cut
 505 */
 506
 507 GV *
 508 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 509 {
 510     GV *gv = gv_fetchmeth(stash, name, len, level);
 511
 512     PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD;
 513
 514     if (!gv) {
 515         CV *cv;
 516         GV **gvp;
 517
 518         if (!stash)
 519             return NULL;        /* UNIVERSAL::AUTOLOAD could cause trouble */
 520         if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
 521             return NULL;
 522         if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
 523             return NULL;
 524         cv = GvCV(gv);
 525         if (!(CvROOT(cv) || CvXSUB(cv)))
 526             return NULL;
 527         /* Have an autoload */
 528         if (level < 0)  /* Cannot do without a stub */
 529             gv_fetchmeth(stash, name, len, 0);
 530         gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 531         if (!gvp)
 532             return NULL;
 533         return *gvp;
 534     }
 535     return gv;
 536 }
 537
 538 /*
 539 =for apidoc gv_fetchmethod_autoload
 540
 541 Returns the glob which contains the subroutine to call to invoke the method
 542 on the C<stash>.  In fact in the presence of autoloading this may be the
 543 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
 544 already setup.
 545
 546 The third parameter of C<gv_fetchmethod_autoload> determines whether
 547 AUTOLOAD lookup is performed if the given method is not present: non-zero
 548 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
 549 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
 550 with a non-zero C<autoload> parameter.
 551
 552 These functions grant C<"SUPER"> token as a prefix of the method name. Note
 553 that if you want to keep the returned glob for a long time, you need to
 554 check for it being "AUTOLOAD", since at the later time the call may load a
 555 different subroutine due to $AUTOLOAD changing its value. Use the glob
 556 created via a side effect to do this.
 557
 558 These functions have the same side-effects and as C<gv_fetchmeth> with
 559 C<level==0>.  C<name> should be writable if contains C<':'> or C<'
 560 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
 561 C<call_sv> apply equally to these functions.
 562
 563 =cut
 564 */
 565
 566 STATIC HV*
 567 S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
 568 {
 569     AV* superisa;
 570     GV** gvp;
 571     GV* gv;
 572     HV* stash;
 573
 574     PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
 575
 576     stash = gv_stashpvn(name, namelen, 0);
 577     if(stash) return stash;
 578
 579     /* If we must create it, give it an @ISA array containing
 580        the real package this SUPER is for, so that it's tied
 581        into the cache invalidation code correctly */
 582     stash = gv_stashpvn(name, namelen, GV_ADD);
 583     gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
 584     gv = *gvp;
 585     gv_init(gv, stash, "ISA", 3, TRUE);
 586     superisa = GvAVn(gv);
 587     GvMULTI_on(gv);
 588     sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
 589 #ifdef USE_ITHREADS
 590     av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0));
 591 #else
 592     av_push(superisa, newSVhek(CopSTASH(PL_curcop)
 593                                ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
 594 #endif
 595
 596     return stash;
 597 }
 598
 599 GV *
 600 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 601 {
 602     PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
 603
 604     return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
 605 }
 606
 607 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
 608    even a U32 hash */
 609 GV *
 610 Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
 611 {
 612     dVAR;
 613     register const char *nend;
 614     const char *nsplit = NULL;
 615     GV* gv;
 616     HV* ostash = stash;
 617     const char * const origname = name;
 618     SV *const error_report = MUTABLE_SV(stash);
 619     const U32 autoload = flags & GV_AUTOLOAD;
 620     const U32 do_croak = flags & GV_CROAK;
 621
 622     PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS;
 623
 624     if (SvTYPE(stash) < SVt_PVHV)
 625         stash = NULL;
 626     else {
 627         /* The only way stash can become NULL later on is if nsplit is set,
 628            which in turn means that there is no need for a SVt_PVHV case
 629            the error reporting code.  */
 630     }
 631
 632     for (nend = name; *nend; nend++) {
 633         if (*nend == '\'') {
 634             nsplit = nend;
 635             name = nend + 1;
 636         }
 637         else if (*nend == ':' && *(nend + 1) == ':') {
 638             nsplit = nend++;
 639             name = nend + 1;
 640         }
 641     }
 642     if (nsplit) {
 643         if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
 644             /* ->SUPER::method should really be looked up in original stash */
 645             SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
 646                                                   CopSTASHPV(PL_curcop)));
 647             /* __PACKAGE__::SUPER stash should be autovivified */
 648             stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr));
 649             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
 650                          origname, HvNAME_get(stash), name) );
 651         }
 652         else {
 653             /* don't autovifify if ->NoSuchStash::method */
 654             stash = gv_stashpvn(origname, nsplit - origname, 0);
 655
 656             /* however, explicit calls to Pkg::SUPER::method may
 657                happen, and may require autovivification to work */
 658             if (!stash && (nsplit - origname) >= 7 &&
 659                 strnEQ(nsplit - 7, "::SUPER", 7) &&
 660                 gv_stashpvn(origname, nsplit - origname - 7, 0))
 661               stash = gv_get_super_pkg(origname, nsplit - origname);
 662         }
 663         ostash = stash;
 664     }
 665
 666     gv = gv_fetchmeth(stash, name, nend - name, 0);
 667     if (!gv) {
 668         if (strEQ(name,"import") || strEQ(name,"unimport"))
 669             gv = MUTABLE_GV(&PL_sv_yes);
 670         else if (autoload)
 671             gv = gv_autoload4(ostash, name, nend - name, TRUE);
 672         if (!gv && do_croak) {
 673             /* Right now this is exclusively for the benefit of S_method_common
 674                in pp_hot.c  */
 675             if (stash) {
 676                 Perl_croak(aTHX_
 677                            "Can't locate object method \"%s\" via package \"%.*s\"",
 678                            name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
 679             }
 680             else {
 681                 STRLEN packlen;
 682                 const char *packname;
 683
 684                 if (nsplit) {
 685                     packlen = nsplit - origname;
 686                     packname = origname;
 687                 } else {
 688                     packname = SvPV_const(error_report, packlen);
 689                 }
 690
 691                 Perl_croak(aTHX_
 692                            "Can't locate object method \"%s\" via package \"%.*s\""
 693                            " (perhaps you forgot to load \"%.*s\"?)",
 694                            name, (int)packlen, packname, (int)packlen, packname);
 695             }
 696         }
 697     }
 698     else if (autoload) {
 699         CV* const cv = GvCV(gv);
 700         if (!CvROOT(cv) && !CvXSUB(cv)) {
 701             GV* stubgv;
 702             GV* autogv;
 703
 704             if (CvANON(cv))
 705                 stubgv = gv;
 706             else {
 707                 stubgv = CvGV(cv);
 708                 if (GvCV(stubgv) != cv)         /* orphaned import */
 709                     stubgv = gv;
 710             }
 711             autogv = gv_autoload4(GvSTASH(stubgv),
 712                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
 713             if (autogv)
 714                 gv = autogv;
 715         }
 716     }
 717
 718     return gv;
 719 }
 720
 721 GV*
 722 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 723 {
 724     dVAR;
 725     GV* gv;
 726     CV* cv;
 727     HV* varstash;
 728     GV* vargv;
 729     SV* varsv;
 730     const char *packname = "";
 731     STRLEN packname_len = 0;
 732
 733     PERL_ARGS_ASSERT_GV_AUTOLOAD4;
 734
 735     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
 736         return NULL;
 737     if (stash) {
 738         if (SvTYPE(stash) < SVt_PVHV) {
 739             packname = SvPV_const(MUTABLE_SV(stash), packname_len);
 740             stash = NULL;
 741         }
 742         else {
 743             packname = HvNAME_get(stash);
 744             packname_len = HvNAMELEN_get(stash);
 745         }
 746     }
 747     if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
 748         return NULL;
 749     cv = GvCV(gv);
 750
 751     if (!(CvROOT(cv) || CvXSUB(cv)))
 752         return NULL;
 753
 754     /*
 755      * Inheriting AUTOLOAD for non-methods works ... for now.
 756      */
 757     if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
 758         && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
 759     )
 760         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 761           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 762              packname, (int)len, name);
 763
 764     if (CvISXSUB(cv)) {
 765         /* rather than lookup/init $AUTOLOAD here
 766          * only to have the XSUB do another lookup for $AUTOLOAD
 767          * and split that value on the last '::',
 768          * pass along the same data via some unused fields in the CV
 769          */
 770         CvSTASH(cv) = stash;
 771         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
 772         SvCUR_set(cv, len);
 773         return gv;
 774     }
 775
 776     /*
 777      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
 778      * The subroutine's original name may not be "AUTOLOAD", so we don't
 779      * use that, but for lack of anything better we will use the sub's
 780      * original package to look up $AUTOLOAD.
 781      */
 782     varstash = GvSTASH(CvGV(cv));
 783     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
 784     ENTER;
 785
 786     if (!isGV(vargv)) {
 787         gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
 788 #ifdef PERL_DONT_CREATE_GVSV
 789         GvSV(vargv) = newSV(0);
 790 #endif
 791     }
 792     LEAVE;
 793     varsv = GvSVn(vargv);
 794     sv_setpvn(varsv, packname, packname_len);
 795     sv_catpvs(varsv, "::");
 796     sv_catpvn(varsv, name, len);
 797     return gv;
 798 }
 799
 800
 801 /* require_tie_mod() internal routine for requiring a module
 802  * that implements the logic of automatical ties like %! and %-
 803  *
 804  * The "gv" parameter should be the glob.
 805  * "varpv" holds the name of the var, used for error messages.
 806  * "namesv" holds the module name. Its refcount will be decremented.
 807  * "methpv" holds the method name to test for to check that things
 808  *   are working reasonably close to as expected.
 809  * "flags": if flag & 1 then save the scalar before loading.
 810  * For the protection of $! to work (it is set by this routine)
 811  * the sv slot must already be magicalized.
 812  */
 813 STATIC HV*
 814 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
 815 {
 816     dVAR;
 817     HV* stash = gv_stashsv(namesv, 0);
 818
 819     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
 820
 821     if (!stash || !(gv_fetchmethod(stash, methpv))) {
 822         SV *module = newSVsv(namesv);
 823         char varname = *varpv; /* varpv might be clobbered by load_module,
 824                                   so save it. For the moment it's always
 825                                   a single char. */
 826         dSP;
 827         ENTER;
 828         if ( flags & 1 )
 829             save_scalar(gv);
 830         PUSHSTACKi(PERLSI_MAGIC);
 831         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
 832         POPSTACK;
 833         LEAVE;
 834         SPAGAIN;
 835         stash = gv_stashsv(namesv, 0);
 836         if (!stash)
 837             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
 838                     varname, SVfARG(namesv));
 839         else if (!gv_fetchmethod(stash, methpv))
 840             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
 841                     varname, SVfARG(namesv), methpv);
 842     }
 843     SvREFCNT_dec(namesv);
 844     return stash;
 845 }
 846
 847 /*
 848 =for apidoc gv_stashpv
 849
 850 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
 851 determine the length of C<name>, then calls C<gv_stashpvn()>.
 852
 853 =cut
 854 */
 855
 856 HV*
 857 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 858 {
 859     PERL_ARGS_ASSERT_GV_STASHPV;
 860     return gv_stashpvn(name, strlen(name), create);
 861 }
 862
 863 /*
 864 =for apidoc gv_stashpvn
 865
 866 Returns a pointer to the stash for a specified package.  The C<namelen>
 867 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
 868 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
 869 created if it does not already exist.  If the package does not exist and
 870 C<flags> is 0 (or any other setting that does not create packages) then NULL
 871 is returned.
 872
 873
 874 =cut
 875 */
 876
 877 HV*
 878 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
 879 {
 880     char smallbuf[128];
 881     char *tmpbuf;
 882     HV *stash;
 883     GV *tmpgv;
 884
 885     PERL_ARGS_ASSERT_GV_STASHPVN;
 886
 887     if (namelen + 2 <= sizeof smallbuf)
 888         tmpbuf = smallbuf;
 889     else
 890         Newx(tmpbuf, namelen + 2, char);
 891     Copy(name,tmpbuf,namelen,char);
 892     tmpbuf[namelen++] = ':';
 893     tmpbuf[namelen++] = ':';
 894     tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, flags, SVt_PVHV);
 895     if (tmpbuf != smallbuf)
 896         Safefree(tmpbuf);
 897     if (!tmpgv)
 898         return NULL;
 899     if (!GvHV(tmpgv))
 900         GvHV(tmpgv) = newHV();
 901     stash = GvHV(tmpgv);
 902     if (!HvNAME_get(stash))
 903         hv_name_set(stash, name, namelen, 0);
 904     return stash;
 905 }
 906
 907 /*
 908 =for apidoc gv_stashsv
 909
 910 Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
 911
 912 =cut
 913 */
 914
 915 HV*
 916 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
 917 {
 918     STRLEN len;
 919     const char * const ptr = SvPV_const(sv,len);
 920
 921     PERL_ARGS_ASSERT_GV_STASHSV;
 922
 923     return gv_stashpvn(ptr, len, flags);
 924 }
 925
 926
 927 GV *
 928 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
 929     PERL_ARGS_ASSERT_GV_FETCHPV;
 930     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
 931 }
 932
 933 GV *
 934 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
 935     STRLEN len;
 936     const char * const nambeg = SvPV_const(name, len);
 937     PERL_ARGS_ASSERT_GV_FETCHSV;
 938     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
 939 }
 940
 941 GV *
 942 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 943                        const svtype sv_type)
 944 {
 945     dVAR;
 946     register const char *name = nambeg;
 947     register GV *gv = NULL;
 948     GV**gvp;
 949     I32 len;
 950     register const char *name_cursor;
 951     HV *stash = NULL;
 952     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
 953     const I32 no_expand = flags & GV_NOEXPAND;
 954     const I32 add = flags & ~GV_NOADD_MASK;
 955     const char *const name_end = nambeg + full_len;
 956     const char *const name_em1 = name_end - 1;
 957     U32 faking_it;
 958
 959     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
 960
 961     if (flags & GV_NOTQUAL) {
 962         /* Caller promised that there is no stash, so we can skip the check. */
 963         len = full_len;
 964         goto no_stash;
 965     }
 966
 967     if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
 968         /* accidental stringify on a GV? */
 969         name++;
 970     }
 971
 972     for (name_cursor = name; name_cursor < name_end; name_cursor++) {
 973         if ((*name_cursor == ':' && name_cursor < name_em1
 974              && name_cursor[1] == ':')
 975             || (*name_cursor == '\'' && name_cursor[1]))
 976         {
 977             if (!stash)
 978                 stash = PL_defstash;
 979             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 980                 return NULL;
 981
 982             len = name_cursor - name;
 983             if (len > 0) {
 984                 char smallbuf[128];
 985                 char *tmpbuf;
 986
 987                 if (len + 2 <= (I32)sizeof (smallbuf))
 988                     tmpbuf = smallbuf;
 989                 else
 990                     Newx(tmpbuf, len+2, char);
 991                 Copy(name, tmpbuf, len, char);
 992                 tmpbuf[len++] = ':';
 993                 tmpbuf[len++] = ':';
 994                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 995                 gv = gvp ? *gvp : NULL;
 996                 if (gv && gv != (const GV *)&PL_sv_undef) {
 997                     if (SvTYPE(gv) != SVt_PVGV)
 998                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 999                     else
1000                         GvMULTI_on(gv);
1001                 }
1002                 if (tmpbuf != smallbuf)
1003                     Safefree(tmpbuf);
1004                 if (!gv || gv == (const GV *)&PL_sv_undef)
1005                     return NULL;
1006
1007                 if (!(stash = GvHV(gv)))
1008                     stash = GvHV(gv) = newHV();
1009
1010                 if (!HvNAME_get(stash))
1011                     hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
1012             }
1013
1014             if (*name_cursor == ':')
1015                 name_cursor++;
1016             name_cursor++;
1017             name = name_cursor;
1018             if (name == name_end)
1019                 return gv
1020                     ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1021         }
1022     }
1023     len = name_cursor - name;
1024
1025     /* No stash in name, so see how we can default */
1026
1027     if (!stash) {
1028     no_stash:
1029         if (len && isIDFIRST_lazy(name)) {
1030             bool global = FALSE;
1031
1032             switch (len) {
1033             case 1:
1034                 if (*name == '_')
1035                     global = TRUE;
1036                 break;
1037             case 3:
1038                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1039                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1040                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1041                     global = TRUE;
1042                 break;
1043             case 4:
1044                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1045                     && name[3] == 'V')
1046                     global = TRUE;
1047                 break;
1048             case 5:
1049                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1050                     && name[3] == 'I' && name[4] == 'N')
1051                     global = TRUE;
1052                 break;
1053             case 6:
1054                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1055                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1056                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1057                     global = TRUE;
1058                 break;
1059             case 7:
1060                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1061                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1062                     && name[6] == 'T')
1063                     global = TRUE;
1064                 break;
1065             }
1066
1067             if (global)
1068                 stash = PL_defstash;
1069             else if (IN_PERL_COMPILETIME) {
1070                 stash = PL_curstash;
1071                 if (add && (PL_hints & HINT_STRICT_VARS) &&
1072                     sv_type != SVt_PVCV &&
1073                     sv_type != SVt_PVGV &&
1074                     sv_type != SVt_PVFM &&
1075                     sv_type != SVt_PVIO &&
1076                     !(len == 1 && sv_type == SVt_PV &&
1077                       (*name == 'a' || *name == 'b')) )
1078                 {
1079                     gvp = (GV**)hv_fetch(stash,name,len,0);
1080                     if (!gvp ||
1081                         *gvp == (const GV *)&PL_sv_undef ||
1082                         SvTYPE(*gvp) != SVt_PVGV)
1083                     {
1084                         stash = NULL;
1085                     }
1086                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1087                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1088                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1089                     {
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
1666 bool
1667 Perl_Gv_AMupdate(pTHX_ HV *stash)
1668 {
1669   dVAR;
1670   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1671   AMT amt;
1672   const struct mro_meta* stash_meta = HvMROMETA(stash);
1673   U32 newgen;
1674
1675   PERL_ARGS_ASSERT_GV_AMUPDATE;
1676
1677   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1678   if (mg) {
1679       const AMT * const amtp = (AMT*)mg->mg_ptr;
1680       if (amtp->was_ok_am == PL_amagic_generation
1681           && amtp->was_ok_sub == newgen) {
1682           return (bool)AMT_OVERLOADED(amtp);
1683       }
1684       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
1685   }
1686
1687   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1688
1689   Zero(&amt,1,AMT);
1690   amt.was_ok_am = PL_amagic_generation;
1691   amt.was_ok_sub = newgen;
1692   amt.fallback = AMGfallNO;
1693   amt.flags = 0;
1694
1695   {
1696     int filled = 0, have_ovl = 0;
1697     int i, lim = 1;
1698
1699     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1700
1701     /* Try to find via inheritance. */
1702     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1703     SV * const sv = gv ? GvSV(gv) : NULL;
1704     CV* cv;
1705
1706     if (!gv)
1707         lim = DESTROY_amg;              /* Skip overloading entries. */
1708 #ifdef PERL_DONT_CREATE_GVSV
1709     else if (!sv) {
1710         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1711     }
1712 #endif
1713     else if (SvTRUE(sv))
1714         amt.fallback=AMGfallYES;
1715     else if (SvOK(sv))
1716         amt.fallback=AMGfallNEVER;
1717
1718     for (i = 1; i < lim; i++)
1719         amt.table[i] = NULL;
1720     for (; i < NofAMmeth; i++) {
1721         const char * const cooky = PL_AMG_names[i];
1722         /* Human-readable form, for debugging: */
1723         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1724         const STRLEN l = PL_AMG_namelens[i];
1725
1726         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1727                      cp, HvNAME_get(stash)) );
1728         /* don't fill the cache while looking up!
1729            Creation of inheritance stubs in intermediate packages may
1730            conflict with the logic of runtime method substitution.
1731            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1732            then we could have created stubs for "(+0" in A and C too.
1733            But if B overloads "bool", we may want to use it for
1734            numifying instead of C's "+0". */
1735         if (i >= DESTROY_amg)
1736             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1737         else                            /* Autoload taken care of below */
1738             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1739         cv = 0;
1740         if (gv && (cv = GvCV(gv))) {
1741             const char *hvname;
1742             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1743                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1744                 /* This is a hack to support autoloading..., while
1745                    knowing *which* methods were declared as overloaded. */
1746                 /* GvSV contains the name of the method. */
1747                 GV *ngv = NULL;
1748                 SV *gvsv = GvSV(gv);
1749
1750                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1751                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1752                              (void*)GvSV(gv), cp, hvname) );
1753                 if (!gvsv || !SvPOK(gvsv)
1754                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1755                                                        FALSE)))
1756                 {
1757                     /* Can be an import stub (created by "can"). */
1758                     const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1759                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1760                                 "in package \"%.256s\"",
1761                                (GvCVGEN(gv) ? "Stub found while resolving"
1762                                 : "Can't resolve"),
1763                                name, cp, hvname);
1764                 }
1765                 cv = GvCV(gv = ngv);
1766             }
1767             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1768                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1769                          GvNAME(CvGV(cv))) );
1770             filled = 1;
1771             if (i < DESTROY_amg)
1772                 have_ovl = 1;
1773         } else if (gv) {                /* Autoloaded... */
1774             cv = MUTABLE_CV(gv);
1775             filled = 1;
1776         }
1777         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
1778     }
1779     if (filled) {
1780       AMT_AMAGIC_on(&amt);
1781       if (have_ovl)
1782           AMT_OVERLOADED_on(&amt);
1783       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
1784                                                 (char*)&amt, sizeof(AMT));
1785       return have_ovl;
1786     }
1787   }
1788   /* Here we have no table: */
1789   /* no_table: */
1790   AMT_AMAGIC_off(&amt);
1791   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
1792                                                 (char*)&amt, sizeof(AMTS));
1793   return FALSE;
1794 }
1795
1796
1797 CV*
1798 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1799 {
1800     dVAR;
1801     MAGIC *mg;
1802     AMT *amtp;
1803     U32 newgen;
1804     struct mro_meta* stash_meta;
1805
1806     if (!stash || !HvNAME_get(stash))
1807         return NULL;
1808
1809     stash_meta = HvMROMETA(stash);
1810     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1811
1812     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1813     if (!mg) {
1814       do_update:
1815         Gv_AMupdate(stash);
1816         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1817     }
1818     assert(mg);
1819     amtp = (AMT*)mg->mg_ptr;
1820     if ( amtp->was_ok_am != PL_amagic_generation
1821          || amtp->was_ok_sub != newgen )
1822         goto do_update;
1823     if (AMT_AMAGIC(amtp)) {
1824         CV * const ret = amtp->table[id];
1825         if (ret && isGV(ret)) {         /* Autoloading stab */
1826             /* Passing it through may have resulted in a warning
1827                "Inherited AUTOLOAD for a non-method deprecated", since
1828                our caller is going through a function call, not a method call.
1829                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1830             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1831
1832             if (gv && GvCV(gv))
1833                 return GvCV(gv);
1834         }
1835         return ret;
1836     }
1837
1838     return NULL;
1839 }
1840
1841
1842 SV*
1843 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1844 {
1845   dVAR;
1846   MAGIC *mg;
1847   CV *cv=NULL;
1848   CV **cvp=NULL, **ocvp=NULL;
1849   AMT *amtp=NULL, *oamtp=NULL;
1850   int off = 0, off1, lr = 0, notfound = 0;
1851   int postpr = 0, force_cpy = 0;
1852   int assign = AMGf_assign & flags;
1853   const int assignshift = assign ? 1 : 0;
1854 #ifdef DEBUGGING
1855   int fl=0;
1856 #endif
1857   HV* stash=NULL;
1858
1859   PERL_ARGS_ASSERT_AMAGIC_CALL;
1860
1861   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
1862       SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
1863                                               0, "overloading", 11, 0, 0);
1864
1865       if ( !lex_mask || !SvOK(lex_mask) )
1866           /* overloading lexically disabled */
1867           return NULL;
1868       else if ( lex_mask && SvPOK(lex_mask) ) {
1869           /* we have an entry in the hints hash, check if method has been
1870            * masked by overloading.pm */
1871           STRLEN len;
1872           const int offset = method / 8;
1873           const int bit    = method % 8;
1874           char *pv = SvPV(lex_mask, len);
1875
1876           /* Bit set, so this overloading operator is disabled */
1877           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
1878               return NULL;
1879       }
1880   }
1881
1882   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1883       && (stash = SvSTASH(SvRV(left)))
1884       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
1885       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1886                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1887                         : NULL))
1888       && ((cv = cvp[off=method+assignshift])
1889           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1890                                                           * usual method */
1891                   (
1892 #ifdef DEBUGGING
1893                    fl = 1,
1894 #endif
1895                    cv = cvp[off=method])))) {
1896     lr = -1;                    /* Call method for left argument */
1897   } else {
1898     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1899       int logic;
1900
1901       /* look for substituted methods */
1902       /* In all the covered cases we should be called with assign==0. */
1903          switch (method) {
1904          case inc_amg:
1905            force_cpy = 1;
1906            if ((cv = cvp[off=add_ass_amg])
1907                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1908              right = &PL_sv_yes; lr = -1; assign = 1;
1909            }
1910            break;
1911          case dec_amg:
1912            force_cpy = 1;
1913            if ((cv = cvp[off = subtr_ass_amg])
1914                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1915              right = &PL_sv_yes; lr = -1; assign = 1;
1916            }
1917            break;
1918          case bool__amg:
1919            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1920            break;
1921          case numer_amg:
1922            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1923            break;
1924          case string_amg:
1925            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1926            break;
1927          case not_amg:
1928            (void)((cv = cvp[off=bool__amg])
1929                   || (cv = cvp[off=numer_amg])
1930                   || (cv = cvp[off=string_amg]));
1931            postpr = 1;
1932            break;
1933          case copy_amg:
1934            {
1935              /*
1936                   * SV* ref causes confusion with the interpreter variable of
1937                   * the same name
1938                   */
1939              SV* const tmpRef=SvRV(left);
1940              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1941                 /*
1942                  * Just to be extra cautious.  Maybe in some
1943                  * additional cases sv_setsv is safe, too.
1944                  */
1945                 SV* const newref = newSVsv(tmpRef);
1946                 SvOBJECT_on(newref);
1947                 /* As a bit of a source compatibility hack, SvAMAGIC() and
1948                    friends dereference an RV, to behave the same was as when
1949                    overloading was stored on the reference, not the referant.
1950                    Hence we can't use SvAMAGIC_on()
1951                 */
1952                 SvFLAGS(newref) |= SVf_AMAGIC;
1953                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
1954                 return newref;
1955              }
1956            }
1957            break;
1958          case abs_amg:
1959            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1960                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1961              SV* const nullsv=sv_2mortal(newSViv(0));
1962              if (off1==lt_amg) {
1963                SV* const lessp = amagic_call(left,nullsv,
1964                                        lt_amg,AMGf_noright);
1965                logic = SvTRUE(lessp);
1966              } else {
1967                SV* const lessp = amagic_call(left,nullsv,
1968                                        ncmp_amg,AMGf_noright);
1969                logic = (SvNV(lessp) < 0);
1970              }
1971              if (logic) {
1972                if (off==subtr_amg) {
1973                  right = left;
1974                  left = nullsv;
1975                  lr = 1;
1976                }
1977              } else {
1978                return left;
1979              }
1980            }
1981            break;
1982          case neg_amg:
1983            if ((cv = cvp[off=subtr_amg])) {
1984              right = left;
1985              left = sv_2mortal(newSViv(0));
1986              lr = 1;
1987            }
1988            break;
1989          case int_amg:
1990          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1991          case ftest_amg:                /* XXXX Eventually should do to_gv. */
1992              /* FAIL safe */
1993              return NULL;       /* Delegate operation to standard mechanisms. */
1994              break;
1995          case to_sv_amg:
1996          case to_av_amg:
1997          case to_hv_amg:
1998          case to_gv_amg:
1999          case to_cv_amg:
2000              /* FAIL safe */
2001              return left;       /* Delegate operation to standard mechanisms. */
2002              break;
2003          default:
2004            goto not_found;
2005          }
2006          if (!cv) goto not_found;
2007     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2008                && (stash = SvSTASH(SvRV(right)))
2009                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2010                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2011                           ? (amtp = (AMT*)mg->mg_ptr)->table
2012                           : NULL))
2013                && (cv = cvp[off=method])) { /* Method for right
2014                                              * argument found */
2015       lr=1;
2016     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
2017                  && (cvp=ocvp) && (lr = -1))
2018                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
2019                && !(flags & AMGf_unary)) {
2020                                 /* We look for substitution for
2021                                  * comparison operations and
2022                                  * concatenation */
2023       if (method==concat_amg || method==concat_ass_amg
2024           || method==repeat_amg || method==repeat_ass_amg) {
2025         return NULL;            /* Delegate operation to string conversion */
2026       }
2027       off = -1;
2028       switch (method) {
2029          case lt_amg:
2030          case le_amg:
2031          case gt_amg:
2032          case ge_amg:
2033          case eq_amg:
2034          case ne_amg:
2035            postpr = 1; off=ncmp_amg; break;
2036          case slt_amg:
2037          case sle_amg:
2038          case sgt_amg:
2039          case sge_amg:
2040          case seq_amg:
2041          case sne_amg:
2042            postpr = 1; off=scmp_amg; break;
2043          }
2044       if (off != -1) cv = cvp[off];
2045       if (!cv) {
2046         goto not_found;
2047       }
2048     } else {
2049     not_found:                  /* No method found, either report or croak */
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          case slt_amg:
2058          case sle_amg:
2059          case sgt_amg:
2060          case sge_amg:
2061          case seq_amg:
2062          case sne_amg:
2063            postpr = 0; break;
2064          case to_sv_amg:
2065          case to_av_amg:
2066          case to_hv_amg:
2067          case to_gv_amg:
2068          case to_cv_amg:
2069              /* FAIL safe */
2070              return left;       /* Delegate operation to standard mechanisms. */
2071              break;
2072       }
2073       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2074         notfound = 1; lr = -1;
2075       } else if (cvp && (cv=cvp[nomethod_amg])) {
2076         notfound = 1; lr = 1;
2077       } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
2078         /* Skip generating the "no method found" message.  */
2079         return NULL;
2080       } else {
2081         SV *msg;
2082         if (off==-1) off=method;
2083         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2084                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
2085                       AMG_id2name(method + assignshift),
2086                       (flags & AMGf_unary ? " " : "\n\tleft "),
2087                       SvAMAGIC(left)?
2088                         "in overloaded package ":
2089                         "has no overloaded magic",
2090                       SvAMAGIC(left)?
2091                         HvNAME_get(SvSTASH(SvRV(left))):
2092                         "",
2093                       SvAMAGIC(right)?
2094                         ",\n\tright argument in overloaded package ":
2095                         (flags & AMGf_unary
2096                          ? ""
2097                          : ",\n\tright argument has no overloaded magic"),
2098                       SvAMAGIC(right)?
2099                         HvNAME_get(SvSTASH(SvRV(right))):
2100                         ""));
2101         if (amtp && amtp->fallback >= AMGfallYES) {
2102           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2103         } else {
2104           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2105         }
2106         return NULL;
2107       }
2108       force_cpy = force_cpy || assign;
2109     }
2110   }
2111 #ifdef DEBUGGING
2112   if (!notfound) {
2113     DEBUG_o(Perl_deb(aTHX_
2114                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2115                      AMG_id2name(off),
2116                      method+assignshift==off? "" :
2117                      " (initially \"",
2118                      method+assignshift==off? "" :
2119                      AMG_id2name(method+assignshift),
2120                      method+assignshift==off? "" : "\")",
2121                      flags & AMGf_unary? "" :
2122                      lr==1 ? " for right argument": " for left argument",
2123                      flags & AMGf_unary? " for argument" : "",
2124                      stash ? HvNAME_get(stash) : "null",
2125                      fl? ",\n\tassignment variant used": "") );
2126   }
2127 #endif
2128     /* Since we use shallow copy during assignment, we need
2129      * to dublicate the contents, probably calling user-supplied
2130      * version of copy operator
2131      */
2132     /* We need to copy in following cases:
2133      * a) Assignment form was called.
2134      *          assignshift==1,  assign==T, method + 1 == off
2135      * b) Increment or decrement, called directly.
2136      *          assignshift==0,  assign==0, method + 0 == off
2137      * c) Increment or decrement, translated to assignment add/subtr.
2138      *          assignshift==0,  assign==T,
2139      *          force_cpy == T
2140      * d) Increment or decrement, translated to nomethod.
2141      *          assignshift==0,  assign==0,
2142      *          force_cpy == T
2143      * e) Assignment form translated to nomethod.
2144      *          assignshift==1,  assign==T, method + 1 != off
2145      *          force_cpy == T
2146      */
2147     /*  off is method, method+assignshift, or a result of opcode substitution.
2148      *  In the latter case assignshift==0, so only notfound case is important.
2149      */
2150   if (( (method + assignshift == off)
2151         && (assign || (method == inc_amg) || (method == dec_amg)))
2152       || force_cpy)
2153     RvDEEPCP(left);
2154   {
2155     dSP;
2156     BINOP myop;
2157     SV* res;
2158     const bool oldcatch = CATCH_GET;
2159
2160     CATCH_SET(TRUE);
2161     Zero(&myop, 1, BINOP);
2162     myop.op_last = (OP *) &myop;
2163     myop.op_next = NULL;
2164     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2165
2166     PUSHSTACKi(PERLSI_OVERLOAD);
2167     ENTER;
2168     SAVEOP();
2169     PL_op = (OP *) &myop;
2170     if (PERLDB_SUB && PL_curstash != PL_debstash)
2171         PL_op->op_private |= OPpENTERSUB_DB;
2172     PUTBACK;
2173     pp_pushmark();
2174
2175     EXTEND(SP, notfound + 5);
2176     PUSHs(lr>0? right: left);
2177     PUSHs(lr>0? left: right);
2178     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2179     if (notfound) {
2180       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2181                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2182     }
2183     PUSHs(MUTABLE_SV(cv));
2184     PUTBACK;
2185
2186     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2187       CALLRUNOPS(aTHX);
2188     LEAVE;
2189     SPAGAIN;
2190
2191     res=POPs;
2192     PUTBACK;
2193     POPSTACK;
2194     CATCH_SET(oldcatch);
2195
2196     if (postpr) {
2197       int ans;
2198       switch (method) {
2199       case le_amg:
2200       case sle_amg:
2201         ans=SvIV(res)<=0; break;
2202       case lt_amg:
2203       case slt_amg:
2204         ans=SvIV(res)<0; break;
2205       case ge_amg:
2206       case sge_amg:
2207         ans=SvIV(res)>=0; break;
2208       case gt_amg:
2209       case sgt_amg:
2210         ans=SvIV(res)>0; break;
2211       case eq_amg:
2212       case seq_amg:
2213         ans=SvIV(res)==0; break;
2214       case ne_amg:
2215       case sne_amg:
2216         ans=SvIV(res)!=0; break;
2217       case inc_amg:
2218       case dec_amg:
2219         SvSetSV(left,res); return left;
2220       case not_amg:
2221         ans=!SvTRUE(res); break;
2222       default:
2223         ans=0; break;
2224       }
2225       return boolSV(ans);
2226     } else if (method==copy_amg) {
2227       if (!SvROK(res)) {
2228         Perl_croak(aTHX_ "Copy method did not return a reference");
2229       }
2230       return SvREFCNT_inc(SvRV(res));
2231     } else {
2232       return res;
2233     }
2234   }
2235 }
2236
2237 /*
2238 =for apidoc is_gv_magical_sv
2239
2240 Returns C<TRUE> if given the name of a magical GV.
2241
2242 Currently only useful internally when determining if a GV should be
2243 created even in rvalue contexts.
2244
2245 C<flags> is not used at present but available for future extension to
2246 allow selecting particular classes of magical variable.
2247
2248 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2249 This assumption is met by all callers within the perl core, which all pass
2250 pointers returned by SvPV.
2251
2252 =cut
2253 */
2254
2255 bool
2256 Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
2257 {
2258     STRLEN len;
2259     const char *const name = SvPV_const(name_sv, len);
2260
2261     PERL_UNUSED_ARG(flags);
2262     PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
2263
2264     if (len > 1) {
2265         const char * const name1 = name + 1;
2266         switch (*name) {
2267         case 'I':
2268             if (len == 3 && name[1] == 'S' && name[2] == 'A')
2269                 goto yes;
2270             break;
2271         case 'O':
2272             if (len == 8 && strEQ(name1, "VERLOAD"))
2273                 goto yes;
2274             break;
2275         case 'S':
2276             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2277                 goto yes;
2278             break;
2279             /* Using ${^...} variables is likely to be sufficiently rare that
2280                it seems sensible to avoid the space hit of also checking the
2281                length.  */
2282         case '\017':   /* ${^OPEN} */
2283             if (strEQ(name1, "PEN"))
2284                 goto yes;
2285             break;
2286         case '\024':   /* ${^TAINT} */
2287             if (strEQ(name1, "AINT"))
2288                 goto yes;
2289             break;
2290         case '\025':    /* ${^UNICODE} */
2291             if (strEQ(name1, "NICODE"))
2292                 goto yes;
2293             if (strEQ(name1, "TF8LOCALE"))
2294                 goto yes;
2295             break;
2296         case '\027':   /* ${^WARNING_BITS} */
2297             if (strEQ(name1, "ARNING_BITS"))
2298                 goto yes;
2299             break;
2300         case '1':
2301         case '2':
2302         case '3':
2303         case '4':
2304         case '5':
2305         case '6':
2306         case '7':
2307         case '8':
2308         case '9':
2309         {
2310             const char *end = name + len;
2311             while (--end > name) {
2312                 if (!isDIGIT(*end))
2313                     return FALSE;
2314             }
2315             goto yes;
2316         }
2317         }
2318     } else {
2319         /* Because we're already assuming that name is NUL terminated
2320            below, we can treat an empty name as "\0"  */
2321         switch (*name) {
2322         case '&':
2323         case '`':
2324         case '\'':
2325         case ':':
2326         case '?':
2327         case '!':
2328         case '-':
2329         case '#':
2330         case '[':
2331         case '^':
2332         case '~':
2333         case '=':
2334         case '%':
2335         case '.':
2336         case '(':
2337         case ')':
2338         case '<':
2339         case '>':
2340         case '\\':
2341         case '/':
2342         case '|':
2343         case '+':
2344         case ';':
2345         case ']':
2346         case '\001':   /* $^A */
2347         case '\003':   /* $^C */
2348         case '\004':   /* $^D */
2349         case '\005':   /* $^E */
2350         case '\006':   /* $^F */
2351         case '\010':   /* $^H */
2352         case '\011':   /* $^I, NOT \t in EBCDIC */
2353         case '\014':   /* $^L */
2354         case '\016':   /* $^N */
2355         case '\017':   /* $^O */
2356         case '\020':   /* $^P */
2357         case '\023':   /* $^S */
2358         case '\024':   /* $^T */
2359         case '\026':   /* $^V */
2360         case '\027':   /* $^W */
2361         case '1':
2362         case '2':
2363         case '3':
2364         case '4':
2365         case '5':
2366         case '6':
2367         case '7':
2368         case '8':
2369         case '9':
2370         yes:
2371             return TRUE;
2372         default:
2373             break;
2374         }
2375     }
2376     return FALSE;
2377 }
2378
2379 void
2380 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2381 {
2382     dVAR;
2383     U32 hash;
2384
2385     PERL_ARGS_ASSERT_GV_NAME_SET;
2386     PERL_UNUSED_ARG(flags);
2387
2388     if (len > I32_MAX)
2389         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2390
2391     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2392         unshare_hek(GvNAME_HEK(gv));
2393     }
2394
2395     PERL_HASH(hash, name, len);
2396     GvNAME_HEK(gv) = share_hek(name, len, hash);
2397 }
2398
2399 /*
2400  * Local variables:
2401  * c-indentation-style: bsd
2402  * c-basic-offset: 4
2403  * indent-tabs-mode: t
2404  * End:
2405  *
2406  * ex: set ts=8 sts=4 sw=4 noet:
2407  */