gv.c

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