gv.c

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