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