gv.c

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