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