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)
1430                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1431 #endif
1432                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1433                         "Name \"%s::%s\" used only once: possible typo",
1434                         HvNAME_get(stash), GvNAME(gv));
1435             }
1436         }
1437     }
1438 }
1439
1440 GV *
1441 Perl_newGVgen(pTHX_ const char *pack)
1442 {
1443     dVAR;
1444     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1445                       GV_ADD, SVt_PVGV);
1446 }
1447
1448 /* hopefully this is only called on local symbol table entries */
1449
1450 GP*
1451 Perl_gp_ref(pTHX_ GP *gp)
1452 {
1453     dVAR;
1454     if (!gp)
1455         return NULL;
1456     gp->gp_refcnt++;
1457     if (gp->gp_cv) {
1458         if (gp->gp_cvgen) {
1459             /* If the GP they asked for a reference to contains
1460                a method cache entry, clear it first, so that we
1461                don't infect them with our cached entry */
1462             SvREFCNT_dec(gp->gp_cv);
1463             gp->gp_cv = NULL;
1464             gp->gp_cvgen = 0;
1465         }
1466     }
1467     return gp;
1468 }
1469
1470 void
1471 Perl_gp_free(pTHX_ GV *gv)
1472 {
1473     dVAR;
1474     GP* gp;
1475
1476     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1477         return;
1478     if (gp->gp_refcnt == 0) {
1479         if (ckWARN_d(WARN_INTERNAL))
1480             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1481                         "Attempt to free unreferenced glob pointers"
1482                         pTHX__FORMAT pTHX__VALUE);
1483         return;
1484     }
1485     if (--gp->gp_refcnt > 0) {
1486         if (gp->gp_egv == gv)
1487             gp->gp_egv = 0;
1488         GvGP(gv) = 0;
1489         return;
1490     }
1491
1492     if (gp->gp_file_hek)
1493         unshare_hek(gp->gp_file_hek);
1494     SvREFCNT_dec(gp->gp_sv);
1495     SvREFCNT_dec(gp->gp_av);
1496     /* FIXME - another reference loop GV -> symtab -> GV ?
1497        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1498     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1499         const char *hvname = HvNAME_get(gp->gp_hv);
1500         if (PL_stashcache && hvname)
1501             (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1502                       G_DISCARD);
1503         SvREFCNT_dec(gp->gp_hv);
1504     }
1505     SvREFCNT_dec(gp->gp_io);
1506     SvREFCNT_dec(gp->gp_cv);
1507     SvREFCNT_dec(gp->gp_form);
1508
1509     Safefree(gp);
1510     GvGP(gv) = 0;
1511 }
1512
1513 int
1514 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1515 {
1516     AMT * const amtp = (AMT*)mg->mg_ptr;
1517     PERL_UNUSED_ARG(sv);
1518
1519     if (amtp && AMT_AMAGIC(amtp)) {
1520         int i;
1521         for (i = 1; i < NofAMmeth; i++) {
1522             CV * const cv = amtp->table[i];
1523             if (cv) {
1524                 SvREFCNT_dec((SV *) cv);
1525                 amtp->table[i] = NULL;
1526             }
1527         }
1528     }
1529  return 0;
1530 }
1531
1532 /* Updates and caches the CV's */
1533
1534 bool
1535 Perl_Gv_AMupdate(pTHX_ HV *stash)
1536 {
1537   dVAR;
1538   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1539   AMT amt;
1540   const struct mro_meta* stash_meta = HvMROMETA(stash);
1541   U32 newgen;
1542
1543   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1544   if (mg) {
1545       const AMT * const amtp = (AMT*)mg->mg_ptr;
1546       if (amtp->was_ok_am == PL_amagic_generation
1547           && amtp->was_ok_sub == newgen) {
1548           return (bool)AMT_OVERLOADED(amtp);
1549       }
1550       sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1551   }
1552
1553   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1554
1555   Zero(&amt,1,AMT);
1556   amt.was_ok_am = PL_amagic_generation;
1557   amt.was_ok_sub = newgen;
1558   amt.fallback = AMGfallNO;
1559   amt.flags = 0;
1560
1561   {
1562     int filled = 0, have_ovl = 0;
1563     int i, lim = 1;
1564
1565     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1566
1567     /* Try to find via inheritance. */
1568     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1569     SV * const sv = gv ? GvSV(gv) : NULL;
1570     CV* cv;
1571
1572     if (!gv)
1573         lim = DESTROY_amg;              /* Skip overloading entries. */
1574 #ifdef PERL_DONT_CREATE_GVSV
1575     else if (!sv) {
1576         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1577     }
1578 #endif
1579     else if (SvTRUE(sv))
1580         amt.fallback=AMGfallYES;
1581     else if (SvOK(sv))
1582         amt.fallback=AMGfallNEVER;
1583
1584     for (i = 1; i < lim; i++)
1585         amt.table[i] = NULL;
1586     for (; i < NofAMmeth; i++) {
1587         const char * const cooky = PL_AMG_names[i];
1588         /* Human-readable form, for debugging: */
1589         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1590         const STRLEN l = PL_AMG_namelens[i];
1591
1592         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1593                      cp, HvNAME_get(stash)) );
1594         /* don't fill the cache while looking up!
1595            Creation of inheritance stubs in intermediate packages may
1596            conflict with the logic of runtime method substitution.
1597            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1598            then we could have created stubs for "(+0" in A and C too.
1599            But if B overloads "bool", we may want to use it for
1600            numifying instead of C's "+0". */
1601         if (i >= DESTROY_amg)
1602             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1603         else                            /* Autoload taken care of below */
1604             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1605         cv = 0;
1606         if (gv && (cv = GvCV(gv))) {
1607             const char *hvname;
1608             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1609                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1610                 /* This is a hack to support autoloading..., while
1611                    knowing *which* methods were declared as overloaded. */
1612                 /* GvSV contains the name of the method. */
1613                 GV *ngv = NULL;
1614                 SV *gvsv = GvSV(gv);
1615
1616                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1617                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1618                              (void*)GvSV(gv), cp, hvname) );
1619                 if (!gvsv || !SvPOK(gvsv)
1620                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1621                                                        FALSE)))
1622                 {
1623                     /* Can be an import stub (created by "can"). */
1624                     const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1625                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1626                                 "in package \"%.256s\"",
1627                                (GvCVGEN(gv) ? "Stub found while resolving"
1628                                 : "Can't resolve"),
1629                                name, cp, hvname);
1630                 }
1631                 cv = GvCV(gv = ngv);
1632             }
1633             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1634                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1635                          GvNAME(CvGV(cv))) );
1636             filled = 1;
1637             if (i < DESTROY_amg)
1638                 have_ovl = 1;
1639         } else if (gv) {                /* Autoloaded... */
1640             cv = (CV*)gv;
1641             filled = 1;
1642         }
1643         amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1644     }
1645     if (filled) {
1646       AMT_AMAGIC_on(&amt);
1647       if (have_ovl)
1648           AMT_OVERLOADED_on(&amt);
1649       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1650                                                 (char*)&amt, sizeof(AMT));
1651       return have_ovl;
1652     }
1653   }
1654   /* Here we have no table: */
1655   /* no_table: */
1656   AMT_AMAGIC_off(&amt);
1657   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1658                                                 (char*)&amt, sizeof(AMTS));
1659   return FALSE;
1660 }
1661
1662
1663 CV*
1664 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1665 {
1666     dVAR;
1667     MAGIC *mg;
1668     AMT *amtp;
1669     U32 newgen;
1670     struct mro_meta* stash_meta;
1671
1672     if (!stash || !HvNAME_get(stash))
1673         return NULL;
1674
1675     stash_meta = HvMROMETA(stash);
1676     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1677
1678     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1679     if (!mg) {
1680       do_update:
1681         Gv_AMupdate(stash);
1682         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1683     }
1684     assert(mg);
1685     amtp = (AMT*)mg->mg_ptr;
1686     if ( amtp->was_ok_am != PL_amagic_generation
1687          || amtp->was_ok_sub != newgen )
1688         goto do_update;
1689     if (AMT_AMAGIC(amtp)) {
1690         CV * const ret = amtp->table[id];
1691         if (ret && isGV(ret)) {         /* Autoloading stab */
1692             /* Passing it through may have resulted in a warning
1693                "Inherited AUTOLOAD for a non-method deprecated", since
1694                our caller is going through a function call, not a method call.
1695                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1696             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1697
1698             if (gv && GvCV(gv))
1699                 return GvCV(gv);
1700         }
1701         return ret;
1702     }
1703
1704     return NULL;
1705 }
1706
1707
1708 SV*
1709 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1710 {
1711   dVAR;
1712   MAGIC *mg;
1713   CV *cv=NULL;
1714   CV **cvp=NULL, **ocvp=NULL;
1715   AMT *amtp=NULL, *oamtp=NULL;
1716   int off = 0, off1, lr = 0, notfound = 0;
1717   int postpr = 0, force_cpy = 0;
1718   int assign = AMGf_assign & flags;
1719   const int assignshift = assign ? 1 : 0;
1720 #ifdef DEBUGGING
1721   int fl=0;
1722 #endif
1723   HV* stash=NULL;
1724   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1725       && (stash = SvSTASH(SvRV(left)))
1726       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1727       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1728                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1729                         : NULL))
1730       && ((cv = cvp[off=method+assignshift])
1731           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1732                                                           * usual method */
1733                   (
1734 #ifdef DEBUGGING
1735                    fl = 1,
1736 #endif
1737                    cv = cvp[off=method])))) {
1738     lr = -1;                    /* Call method for left argument */
1739   } else {
1740     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1741       int logic;
1742
1743       /* look for substituted methods */
1744       /* In all the covered cases we should be called with assign==0. */
1745          switch (method) {
1746          case inc_amg:
1747            force_cpy = 1;
1748            if ((cv = cvp[off=add_ass_amg])
1749                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1750              right = &PL_sv_yes; lr = -1; assign = 1;
1751            }
1752            break;
1753          case dec_amg:
1754            force_cpy = 1;
1755            if ((cv = cvp[off = subtr_ass_amg])
1756                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1757              right = &PL_sv_yes; lr = -1; assign = 1;
1758            }
1759            break;
1760          case bool__amg:
1761            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1762            break;
1763          case numer_amg:
1764            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1765            break;
1766          case string_amg:
1767            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1768            break;
1769          case not_amg:
1770            (void)((cv = cvp[off=bool__amg])
1771                   || (cv = cvp[off=numer_amg])
1772                   || (cv = cvp[off=string_amg]));
1773            postpr = 1;
1774            break;
1775          case copy_amg:
1776            {
1777              /*
1778                   * SV* ref causes confusion with the interpreter variable of
1779                   * the same name
1780                   */
1781              SV* const tmpRef=SvRV(left);
1782              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1783                 /*
1784                  * Just to be extra cautious.  Maybe in some
1785                  * additional cases sv_setsv is safe, too.
1786                  */
1787                 SV* const newref = newSVsv(tmpRef);
1788                 SvOBJECT_on(newref);
1789                 /* As a bit of a source compatibility hack, SvAMAGIC() and
1790                    friends dereference an RV, to behave the same was as when
1791                    overloading was stored on the reference, not the referant.
1792                    Hence we can't use SvAMAGIC_on()
1793                 */
1794                 SvFLAGS(newref) |= SVf_AMAGIC;
1795                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1796                 return newref;
1797              }
1798            }
1799            break;
1800          case abs_amg:
1801            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1802                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1803              SV* const nullsv=sv_2mortal(newSViv(0));
1804              if (off1==lt_amg) {
1805                SV* const lessp = amagic_call(left,nullsv,
1806                                        lt_amg,AMGf_noright);
1807                logic = SvTRUE(lessp);
1808              } else {
1809                SV* const lessp = amagic_call(left,nullsv,
1810                                        ncmp_amg,AMGf_noright);
1811                logic = (SvNV(lessp) < 0);
1812              }
1813              if (logic) {
1814                if (off==subtr_amg) {
1815                  right = left;
1816                  left = nullsv;
1817                  lr = 1;
1818                }
1819              } else {
1820                return left;
1821              }
1822            }
1823            break;
1824          case neg_amg:
1825            if ((cv = cvp[off=subtr_amg])) {
1826              right = left;
1827              left = sv_2mortal(newSViv(0));
1828              lr = 1;
1829            }
1830            break;
1831          case int_amg:
1832          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1833              /* FAIL safe */
1834              return NULL;       /* Delegate operation to standard mechanisms. */
1835              break;
1836          case to_sv_amg:
1837          case to_av_amg:
1838          case to_hv_amg:
1839          case to_gv_amg:
1840          case to_cv_amg:
1841              /* FAIL safe */
1842              return left;       /* Delegate operation to standard mechanisms. */
1843              break;
1844          default:
1845            goto not_found;
1846          }
1847          if (!cv) goto not_found;
1848     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1849                && (stash = SvSTASH(SvRV(right)))
1850                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1851                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1852                           ? (amtp = (AMT*)mg->mg_ptr)->table
1853                           : NULL))
1854                && (cv = cvp[off=method])) { /* Method for right
1855                                              * argument found */
1856       lr=1;
1857     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1858                  && (cvp=ocvp) && (lr = -1))
1859                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1860                && !(flags & AMGf_unary)) {
1861                                 /* We look for substitution for
1862                                  * comparison operations and
1863                                  * concatenation */
1864       if (method==concat_amg || method==concat_ass_amg
1865           || method==repeat_amg || method==repeat_ass_amg) {
1866         return NULL;            /* Delegate operation to string conversion */
1867       }
1868       off = -1;
1869       switch (method) {
1870          case lt_amg:
1871          case le_amg:
1872          case gt_amg:
1873          case ge_amg:
1874          case eq_amg:
1875          case ne_amg:
1876            postpr = 1; off=ncmp_amg; break;
1877          case slt_amg:
1878          case sle_amg:
1879          case sgt_amg:
1880          case sge_amg:
1881          case seq_amg:
1882          case sne_amg:
1883            postpr = 1; off=scmp_amg; break;
1884          }
1885       if (off != -1) cv = cvp[off];
1886       if (!cv) {
1887         goto not_found;
1888       }
1889     } else {
1890     not_found:                  /* No method found, either report or croak */
1891       switch (method) {
1892          case lt_amg:
1893          case le_amg:
1894          case gt_amg:
1895          case ge_amg:
1896          case eq_amg:
1897          case ne_amg:
1898          case slt_amg:
1899          case sle_amg:
1900          case sgt_amg:
1901          case sge_amg:
1902          case seq_amg:
1903          case sne_amg:
1904            postpr = 0; break;
1905          case to_sv_amg:
1906          case to_av_amg:
1907          case to_hv_amg:
1908          case to_gv_amg:
1909          case to_cv_amg:
1910              /* FAIL safe */
1911              return left;       /* Delegate operation to standard mechanisms. */
1912              break;
1913       }
1914       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1915         notfound = 1; lr = -1;
1916       } else if (cvp && (cv=cvp[nomethod_amg])) {
1917         notfound = 1; lr = 1;
1918       } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
1919         /* Skip generating the "no method found" message.  */
1920         return NULL;
1921       } else {
1922         SV *msg;
1923         if (off==-1) off=method;
1924         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1925                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1926                       AMG_id2name(method + assignshift),
1927                       (flags & AMGf_unary ? " " : "\n\tleft "),
1928                       SvAMAGIC(left)?
1929                         "in overloaded package ":
1930                         "has no overloaded magic",
1931                       SvAMAGIC(left)?
1932                         HvNAME_get(SvSTASH(SvRV(left))):
1933                         "",
1934                       SvAMAGIC(right)?
1935                         ",\n\tright argument in overloaded package ":
1936                         (flags & AMGf_unary
1937                          ? ""
1938                          : ",\n\tright argument has no overloaded magic"),
1939                       SvAMAGIC(right)?
1940                         HvNAME_get(SvSTASH(SvRV(right))):
1941                         ""));
1942         if (amtp && amtp->fallback >= AMGfallYES) {
1943           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1944         } else {
1945           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
1946         }
1947         return NULL;
1948       }
1949       force_cpy = force_cpy || assign;
1950     }
1951   }
1952 #ifdef DEBUGGING
1953   if (!notfound) {
1954     DEBUG_o(Perl_deb(aTHX_
1955                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1956                      AMG_id2name(off),
1957                      method+assignshift==off? "" :
1958                      " (initially \"",
1959                      method+assignshift==off? "" :
1960                      AMG_id2name(method+assignshift),
1961                      method+assignshift==off? "" : "\")",
1962                      flags & AMGf_unary? "" :
1963                      lr==1 ? " for right argument": " for left argument",
1964                      flags & AMGf_unary? " for argument" : "",
1965                      stash ? HvNAME_get(stash) : "null",
1966                      fl? ",\n\tassignment variant used": "") );
1967   }
1968 #endif
1969     /* Since we use shallow copy during assignment, we need
1970      * to dublicate the contents, probably calling user-supplied
1971      * version of copy operator
1972      */
1973     /* We need to copy in following cases:
1974      * a) Assignment form was called.
1975      *          assignshift==1,  assign==T, method + 1 == off
1976      * b) Increment or decrement, called directly.
1977      *          assignshift==0,  assign==0, method + 0 == off
1978      * c) Increment or decrement, translated to assignment add/subtr.
1979      *          assignshift==0,  assign==T,
1980      *          force_cpy == T
1981      * d) Increment or decrement, translated to nomethod.
1982      *          assignshift==0,  assign==0,
1983      *          force_cpy == T
1984      * e) Assignment form translated to nomethod.
1985      *          assignshift==1,  assign==T, method + 1 != off
1986      *          force_cpy == T
1987      */
1988     /*  off is method, method+assignshift, or a result of opcode substitution.
1989      *  In the latter case assignshift==0, so only notfound case is important.
1990      */
1991   if (( (method + assignshift == off)
1992         && (assign || (method == inc_amg) || (method == dec_amg)))
1993       || force_cpy)
1994     RvDEEPCP(left);
1995   {
1996     dSP;
1997     BINOP myop;
1998     SV* res;
1999     const bool oldcatch = CATCH_GET;
2000
2001     CATCH_SET(TRUE);
2002     Zero(&myop, 1, BINOP);
2003     myop.op_last = (OP *) &myop;
2004     myop.op_next = NULL;
2005     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2006
2007     PUSHSTACKi(PERLSI_OVERLOAD);
2008     ENTER;
2009     SAVEOP();
2010     PL_op = (OP *) &myop;
2011     if (PERLDB_SUB && PL_curstash != PL_debstash)
2012         PL_op->op_private |= OPpENTERSUB_DB;
2013     PUTBACK;
2014     pp_pushmark();
2015
2016     EXTEND(SP, notfound + 5);
2017     PUSHs(lr>0? right: left);
2018     PUSHs(lr>0? left: right);
2019     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2020     if (notfound) {
2021       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
2022     }
2023     PUSHs((SV*)cv);
2024     PUTBACK;
2025
2026     if ((PL_op = Perl_pp_entersub(aTHX)))
2027       CALLRUNOPS(aTHX);
2028     LEAVE;
2029     SPAGAIN;
2030
2031     res=POPs;
2032     PUTBACK;
2033     POPSTACK;
2034     CATCH_SET(oldcatch);
2035
2036     if (postpr) {
2037       int ans;
2038       switch (method) {
2039       case le_amg:
2040       case sle_amg:
2041         ans=SvIV(res)<=0; break;
2042       case lt_amg:
2043       case slt_amg:
2044         ans=SvIV(res)<0; break;
2045       case ge_amg:
2046       case sge_amg:
2047         ans=SvIV(res)>=0; break;
2048       case gt_amg:
2049       case sgt_amg:
2050         ans=SvIV(res)>0; break;
2051       case eq_amg:
2052       case seq_amg:
2053         ans=SvIV(res)==0; break;
2054       case ne_amg:
2055       case sne_amg:
2056         ans=SvIV(res)!=0; break;
2057       case inc_amg:
2058       case dec_amg:
2059         SvSetSV(left,res); return left;
2060       case not_amg:
2061         ans=!SvTRUE(res); break;
2062       default:
2063         ans=0; break;
2064       }
2065       return boolSV(ans);
2066     } else if (method==copy_amg) {
2067       if (!SvROK(res)) {
2068         Perl_croak(aTHX_ "Copy method did not return a reference");
2069       }
2070       return SvREFCNT_inc(SvRV(res));
2071     } else {
2072       return res;
2073     }
2074   }
2075 }
2076
2077 /*
2078 =for apidoc is_gv_magical_sv
2079
2080 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
2081
2082 =cut
2083 */
2084
2085 bool
2086 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
2087 {
2088     STRLEN len;
2089     const char * const temp = SvPV_const(name, len);
2090     return is_gv_magical(temp, len, flags);
2091 }
2092
2093 /*
2094 =for apidoc is_gv_magical
2095
2096 Returns C<TRUE> if given the name of a magical GV.
2097
2098 Currently only useful internally when determining if a GV should be
2099 created even in rvalue contexts.
2100
2101 C<flags> is not used at present but available for future extension to
2102 allow selecting particular classes of magical variable.
2103
2104 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2105 This assumption is met by all callers within the perl core, which all pass
2106 pointers returned by SvPV.
2107
2108 =cut
2109 */
2110 bool
2111 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
2112 {
2113     PERL_UNUSED_CONTEXT;
2114     PERL_UNUSED_ARG(flags);
2115
2116     if (len > 1) {
2117         const char * const name1 = name + 1;
2118         switch (*name) {
2119         case 'I':
2120             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
2121                 goto yes;
2122             break;
2123         case 'O':
2124             if (len == 8 && strEQ(name1, "VERLOAD"))
2125                 goto yes;
2126             break;
2127         case 'S':
2128             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2129                 goto yes;
2130             break;
2131             /* Using ${^...} variables is likely to be sufficiently rare that
2132                it seems sensible to avoid the space hit of also checking the
2133                length.  */
2134         case '\017':   /* ${^OPEN} */
2135             if (strEQ(name1, "PEN"))
2136                 goto yes;
2137             break;
2138         case '\024':   /* ${^TAINT} */
2139             if (strEQ(name1, "AINT"))
2140                 goto yes;
2141             break;
2142         case '\025':    /* ${^UNICODE} */
2143             if (strEQ(name1, "NICODE"))
2144                 goto yes;
2145             if (strEQ(name1, "TF8LOCALE"))
2146                 goto yes;
2147             break;
2148         case '\027':   /* ${^WARNING_BITS} */
2149             if (strEQ(name1, "ARNING_BITS"))
2150                 goto yes;
2151             break;
2152         case '1':
2153         case '2':
2154         case '3':
2155         case '4':
2156         case '5':
2157         case '6':
2158         case '7':
2159         case '8':
2160         case '9':
2161         {
2162             const char *end = name + len;
2163             while (--end > name) {
2164                 if (!isDIGIT(*end))
2165                     return FALSE;
2166             }
2167             goto yes;
2168         }
2169         }
2170     } else {
2171         /* Because we're already assuming that name is NUL terminated
2172            below, we can treat an empty name as "\0"  */
2173         switch (*name) {
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 ']':
2199         case '\001':   /* $^A */
2200         case '\003':   /* $^C */
2201         case '\004':   /* $^D */
2202         case '\005':   /* $^E */
2203         case '\006':   /* $^F */
2204         case '\010':   /* $^H */
2205         case '\011':   /* $^I, NOT \t in EBCDIC */
2206         case '\014':   /* $^L */
2207         case '\016':   /* $^N */
2208         case '\017':   /* $^O */
2209         case '\020':   /* $^P */
2210         case '\023':   /* $^S */
2211         case '\024':   /* $^T */
2212         case '\026':   /* $^V */
2213         case '\027':   /* $^W */
2214         case '1':
2215         case '2':
2216         case '3':
2217         case '4':
2218         case '5':
2219         case '6':
2220         case '7':
2221         case '8':
2222         case '9':
2223         yes:
2224             return TRUE;
2225         default:
2226             break;
2227         }
2228     }
2229     return FALSE;
2230 }
2231
2232 void
2233 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2234 {
2235     dVAR;
2236     U32 hash;
2237
2238     assert(name);
2239     PERL_UNUSED_ARG(flags);
2240
2241     if (len > I32_MAX)
2242         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2243
2244     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2245         unshare_hek(GvNAME_HEK(gv));
2246     }
2247
2248     PERL_HASH(hash, name, len);
2249     GvNAME_HEK(gv) = share_hek(name, len, hash);
2250 }
2251
2252 /*
2253  * Local variables:
2254  * c-indentation-style: bsd
2255  * c-basic-offset: 4
2256  * indent-tabs-mode: t
2257  * End:
2258  *
2259  * ex: set ts=8 sts=4 sw=4 noet:
2260  */