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