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;
 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 = 0;
 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 = 0;
 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 '+':
1160         {
1161             AV* const av = GvAVn(gv);
1162             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 0);
1163             SvREADONLY_on(av);
1164             /* FALL THROUGH */
1165         }
1166         case '\023':    /* $^S */
1167         case '1':
1168         case '2':
1169         case '3':
1170         case '4':
1171         case '5':
1172         case '6':
1173         case '7':
1174         case '8':
1175         case '9':
1176         ro_magicalize:
1177             SvREADONLY_on(GvSVn(gv));
1178             /* FALL THROUGH */
1179         case '[':
1180         case '^':
1181         case '~':
1182         case '=':
1183         case '%':
1184         case '.':
1185         case '(':
1186         case ')':
1187         case '<':
1188         case '>':
1189         case ',':
1190         case '\\':
1191         case '/':
1192         case '\001':    /* $^A */
1193         case '\003':    /* $^C */
1194         case '\004':    /* $^D */
1195         case '\005':    /* $^E */
1196         case '\006':    /* $^F */
1197         case '\010':    /* $^H */
1198         case '\011':    /* $^I, NOT \t in EBCDIC */
1199         case '\016':    /* $^N */
1200         case '\017':    /* $^O */
1201         case '\020':    /* $^P */
1202         case '\024':    /* $^T */
1203         case '\027':    /* $^W */
1204         magicalize:
1205             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1206             break;
1207
1208         case '\014':    /* $^L */
1209             sv_setpvn(GvSVn(gv),"\f",1);
1210             PL_formfeed = GvSVn(gv);
1211             break;
1212         case ';':
1213             sv_setpvn(GvSVn(gv),"\034",1);
1214             break;
1215         case ']':
1216         {
1217             SV * const sv = GvSVn(gv);
1218             if (!sv_derived_from(PL_patchlevel, "version"))
1219                 upg_version(PL_patchlevel);
1220             GvSV(gv) = vnumify(PL_patchlevel);
1221             SvREADONLY_on(GvSV(gv));
1222             SvREFCNT_dec(sv);
1223         }
1224         break;
1225         case '\026':    /* $^V */
1226         {
1227             SV * const sv = GvSVn(gv);
1228             GvSV(gv) = new_version(PL_patchlevel);
1229             SvREADONLY_on(GvSV(gv));
1230             SvREFCNT_dec(sv);
1231         }
1232         break;
1233         }
1234     }
1235     return gv;
1236 }
1237
1238 void
1239 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1240 {
1241     const char *name;
1242     STRLEN namelen;
1243     const HV * const hv = GvSTASH(gv);
1244     if (!hv) {
1245         SvOK_off(sv);
1246         return;
1247     }
1248     sv_setpv(sv, prefix ? prefix : "");
1249
1250     name = HvNAME_get(hv);
1251     if (name) {
1252         namelen = HvNAMELEN_get(hv);
1253     } else {
1254         name = "__ANON__";
1255         namelen = 8;
1256     }
1257
1258     if (keepmain || strNE(name, "main")) {
1259         sv_catpvn(sv,name,namelen);
1260         sv_catpvs(sv,"::");
1261     }
1262     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1263 }
1264
1265 void
1266 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1267 {
1268     const GV * const egv = GvEGV(gv);
1269     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1270 }
1271
1272 IO *
1273 Perl_newIO(pTHX)
1274 {
1275     dVAR;
1276     GV *iogv;
1277     IO * const io = (IO*)newSV(0);
1278
1279     sv_upgrade((SV *)io,SVt_PVIO);
1280     /* This used to read SvREFCNT(io) = 1;
1281        It's not clear why the reference count needed an explicit reset. NWC
1282     */
1283     assert (SvREFCNT(io) == 1);
1284     SvOBJECT_on(io);
1285     /* Clear the stashcache because a new IO could overrule a package name */
1286     hv_clear(PL_stashcache);
1287     iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1288     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1289     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1290       iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1291     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1292     return io;
1293 }
1294
1295 void
1296 Perl_gv_check(pTHX_ HV *stash)
1297 {
1298     dVAR;
1299     register I32 i;
1300
1301     if (!HvARRAY(stash))
1302         return;
1303     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1304         const HE *entry;
1305         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1306             register GV *gv;
1307             HV *hv;
1308             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1309                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1310             {
1311                 if (hv != PL_defstash && hv != stash)
1312                      gv_check(hv);              /* nested package */
1313             }
1314             else if (isALPHA(*HeKEY(entry))) {
1315                 const char *file;
1316                 gv = (GV*)HeVAL(entry);
1317                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1318                     continue;
1319                 file = GvFILE(gv);
1320                 /* performance hack: if filename is absolute and it's a standard
1321                  * module, don't bother warning */
1322 #ifdef MACOS_TRADITIONAL
1323 #   define LIB_COMPONENT ":lib:"
1324 #else
1325 #   define LIB_COMPONENT "/lib/"
1326 #endif
1327                 if (file
1328                     && PERL_FILE_IS_ABSOLUTE(file)
1329                     && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1330                 {
1331                     continue;
1332                 }
1333                 CopLINE_set(PL_curcop, GvLINE(gv));
1334 #ifdef USE_ITHREADS
1335                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1336 #else
1337                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1338 #endif
1339                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1340                         "Name \"%s::%s\" used only once: possible typo",
1341                         HvNAME_get(stash), GvNAME(gv));
1342             }
1343         }
1344     }
1345 }
1346
1347 GV *
1348 Perl_newGVgen(pTHX_ const char *pack)
1349 {
1350     dVAR;
1351     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1352                       GV_ADD, SVt_PVGV);
1353 }
1354
1355 /* hopefully this is only called on local symbol table entries */
1356
1357 GP*
1358 Perl_gp_ref(pTHX_ GP *gp)
1359 {
1360     dVAR;
1361     if (!gp)
1362         return (GP*)NULL;
1363     gp->gp_refcnt++;
1364     if (gp->gp_cv) {
1365         if (gp->gp_cvgen) {
1366             /* multi-named GPs cannot be used for method cache */
1367             SvREFCNT_dec(gp->gp_cv);
1368             gp->gp_cv = NULL;
1369             gp->gp_cvgen = 0;
1370         }
1371         else {
1372             /* Adding a new name to a subroutine invalidates method cache */
1373             PL_sub_generation++;
1374         }
1375     }
1376     return gp;
1377 }
1378
1379 void
1380 Perl_gp_free(pTHX_ GV *gv)
1381 {
1382     dVAR;
1383     GP* gp;
1384
1385     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1386         return;
1387     if (gp->gp_refcnt == 0) {
1388         if (ckWARN_d(WARN_INTERNAL))
1389             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1390                         "Attempt to free unreferenced glob pointers"
1391                         pTHX__FORMAT pTHX__VALUE);
1392         return;
1393     }
1394     if (gp->gp_cv) {
1395         /* Deleting the name of a subroutine invalidates method cache */
1396         PL_sub_generation++;
1397     }
1398     if (--gp->gp_refcnt > 0) {
1399         if (gp->gp_egv == gv)
1400             gp->gp_egv = 0;
1401         GvGP(gv) = 0;
1402         return;
1403     }
1404
1405     if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1406     if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1407     /* FIXME - another reference loop GV -> symtab -> GV ?
1408        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1409     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1410         const char *hvname = HvNAME_get(gp->gp_hv);
1411         if (PL_stashcache && hvname)
1412             hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1413                       G_DISCARD);
1414         SvREFCNT_dec(gp->gp_hv);
1415     }
1416     if (gp->gp_io)   SvREFCNT_dec(gp->gp_io);
1417     if (gp->gp_cv)   SvREFCNT_dec(gp->gp_cv);
1418     if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1419
1420     Safefree(gp);
1421     GvGP(gv) = 0;
1422 }
1423
1424 int
1425 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1426 {
1427     AMT * const amtp = (AMT*)mg->mg_ptr;
1428     PERL_UNUSED_ARG(sv);
1429
1430     if (amtp && AMT_AMAGIC(amtp)) {
1431         int i;
1432         for (i = 1; i < NofAMmeth; i++) {
1433             CV * const cv = amtp->table[i];
1434             if (cv) {
1435                 SvREFCNT_dec((SV *) cv);
1436                 amtp->table[i] = NULL;
1437             }
1438         }
1439     }
1440  return 0;
1441 }
1442
1443 /* Updates and caches the CV's */
1444
1445 bool
1446 Perl_Gv_AMupdate(pTHX_ HV *stash)
1447 {
1448   dVAR;
1449   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1450   AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1451   AMT amt;
1452
1453   if (mg && amtp->was_ok_am == PL_amagic_generation
1454       && amtp->was_ok_sub == PL_sub_generation)
1455       return (bool)AMT_OVERLOADED(amtp);
1456   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1457
1458   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1459
1460   Zero(&amt,1,AMT);
1461   amt.was_ok_am = PL_amagic_generation;
1462   amt.was_ok_sub = PL_sub_generation;
1463   amt.fallback = AMGfallNO;
1464   amt.flags = 0;
1465
1466   {
1467     int filled = 0, have_ovl = 0;
1468     int i, lim = 1;
1469
1470     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1471
1472     /* Try to find via inheritance. */
1473     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1474     SV * const sv = gv ? GvSV(gv) : NULL;
1475     CV* cv;
1476
1477     if (!gv)
1478         lim = DESTROY_amg;              /* Skip overloading entries. */
1479 #ifdef PERL_DONT_CREATE_GVSV
1480     else if (!sv) {
1481         /*EMPTY*/;   /* Equivalent to !SvTRUE and !SvOK  */
1482     }
1483 #endif
1484     else if (SvTRUE(sv))
1485         amt.fallback=AMGfallYES;
1486     else if (SvOK(sv))
1487         amt.fallback=AMGfallNEVER;
1488
1489     for (i = 1; i < lim; i++)
1490         amt.table[i] = NULL;
1491     for (; i < NofAMmeth; i++) {
1492         const char * const cooky = PL_AMG_names[i];
1493         /* Human-readable form, for debugging: */
1494         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1495         const STRLEN l = strlen(cooky);
1496
1497         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1498                      cp, HvNAME_get(stash)) );
1499         /* don't fill the cache while looking up!
1500            Creation of inheritance stubs in intermediate packages may
1501            conflict with the logic of runtime method substitution.
1502            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1503            then we could have created stubs for "(+0" in A and C too.
1504            But if B overloads "bool", we may want to use it for
1505            numifying instead of C's "+0". */
1506         if (i >= DESTROY_amg)
1507             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1508         else                            /* Autoload taken care of below */
1509             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1510         cv = 0;
1511         if (gv && (cv = GvCV(gv))) {
1512             const char *hvname;
1513             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1514                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1515                 /* This is a hack to support autoloading..., while
1516                    knowing *which* methods were declared as overloaded. */
1517                 /* GvSV contains the name of the method. */
1518                 GV *ngv = NULL;
1519                 SV *gvsv = GvSV(gv);
1520
1521                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1522                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1523                              GvSV(gv), cp, hvname) );
1524                 if (!gvsv || !SvPOK(gvsv)
1525                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1526                                                        FALSE)))
1527                 {
1528                     /* Can be an import stub (created by "can"). */
1529                     const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1530                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1531                                 "in package \"%.256s\"",
1532                                (GvCVGEN(gv) ? "Stub found while resolving"
1533                                 : "Can't resolve"),
1534                                name, cp, hvname);
1535                 }
1536                 cv = GvCV(gv = ngv);
1537             }
1538             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1539                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1540                          GvNAME(CvGV(cv))) );
1541             filled = 1;
1542             if (i < DESTROY_amg)
1543                 have_ovl = 1;
1544         } else if (gv) {                /* Autoloaded... */
1545             cv = (CV*)gv;
1546             filled = 1;
1547         }
1548         amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1549     }
1550     if (filled) {
1551       AMT_AMAGIC_on(&amt);
1552       if (have_ovl)
1553           AMT_OVERLOADED_on(&amt);
1554       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1555                                                 (char*)&amt, sizeof(AMT));
1556       return have_ovl;
1557     }
1558   }
1559   /* Here we have no table: */
1560   /* no_table: */
1561   AMT_AMAGIC_off(&amt);
1562   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1563                                                 (char*)&amt, sizeof(AMTS));
1564   return FALSE;
1565 }
1566
1567
1568 CV*
1569 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1570 {
1571     dVAR;
1572     MAGIC *mg;
1573     AMT *amtp;
1574
1575     if (!stash || !HvNAME_get(stash))
1576         return NULL;
1577     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1578     if (!mg) {
1579       do_update:
1580         Gv_AMupdate(stash);
1581         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1582     }
1583     amtp = (AMT*)mg->mg_ptr;
1584     if ( amtp->was_ok_am != PL_amagic_generation
1585          || amtp->was_ok_sub != PL_sub_generation )
1586         goto do_update;
1587     if (AMT_AMAGIC(amtp)) {
1588         CV * const ret = amtp->table[id];
1589         if (ret && isGV(ret)) {         /* Autoloading stab */
1590             /* Passing it through may have resulted in a warning
1591                "Inherited AUTOLOAD for a non-method deprecated", since
1592                our caller is going through a function call, not a method call.
1593                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1594             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1595
1596             if (gv && GvCV(gv))
1597                 return GvCV(gv);
1598         }
1599         return ret;
1600     }
1601
1602     return NULL;
1603 }
1604
1605
1606 SV*
1607 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1608 {
1609   dVAR;
1610   MAGIC *mg;
1611   CV *cv=NULL;
1612   CV **cvp=NULL, **ocvp=NULL;
1613   AMT *amtp=NULL, *oamtp=NULL;
1614   int off = 0, off1, lr = 0, notfound = 0;
1615   int postpr = 0, force_cpy = 0;
1616   int assign = AMGf_assign & flags;
1617   const int assignshift = assign ? 1 : 0;
1618 #ifdef DEBUGGING
1619   int fl=0;
1620 #endif
1621   HV* stash=NULL;
1622   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1623       && (stash = SvSTASH(SvRV(left)))
1624       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1625       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1626                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1627                         : (CV **) NULL))
1628       && ((cv = cvp[off=method+assignshift])
1629           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1630                                                           * usual method */
1631                   (
1632 #ifdef DEBUGGING
1633                    fl = 1,
1634 #endif
1635                    cv = cvp[off=method])))) {
1636     lr = -1;                    /* Call method for left argument */
1637   } else {
1638     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1639       int logic;
1640
1641       /* look for substituted methods */
1642       /* In all the covered cases we should be called with assign==0. */
1643          switch (method) {
1644          case inc_amg:
1645            force_cpy = 1;
1646            if ((cv = cvp[off=add_ass_amg])
1647                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1648              right = &PL_sv_yes; lr = -1; assign = 1;
1649            }
1650            break;
1651          case dec_amg:
1652            force_cpy = 1;
1653            if ((cv = cvp[off = subtr_ass_amg])
1654                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1655              right = &PL_sv_yes; lr = -1; assign = 1;
1656            }
1657            break;
1658          case bool__amg:
1659            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1660            break;
1661          case numer_amg:
1662            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1663            break;
1664          case string_amg:
1665            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1666            break;
1667          case not_amg:
1668            (void)((cv = cvp[off=bool__amg])
1669                   || (cv = cvp[off=numer_amg])
1670                   || (cv = cvp[off=string_amg]));
1671            postpr = 1;
1672            break;
1673          case copy_amg:
1674            {
1675              /*
1676                   * SV* ref causes confusion with the interpreter variable of
1677                   * the same name
1678                   */
1679              SV* const tmpRef=SvRV(left);
1680              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1681                 /*
1682                  * Just to be extra cautious.  Maybe in some
1683                  * additional cases sv_setsv is safe, too.
1684                  */
1685                 SV* const newref = newSVsv(tmpRef);
1686                 SvOBJECT_on(newref);
1687                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1688                 return newref;
1689              }
1690            }
1691            break;
1692          case abs_amg:
1693            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1694                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1695              SV* const nullsv=sv_2mortal(newSViv(0));
1696              if (off1==lt_amg) {
1697                SV* const lessp = amagic_call(left,nullsv,
1698                                        lt_amg,AMGf_noright);
1699                logic = SvTRUE(lessp);
1700              } else {
1701                SV* const lessp = amagic_call(left,nullsv,
1702                                        ncmp_amg,AMGf_noright);
1703                logic = (SvNV(lessp) < 0);
1704              }
1705              if (logic) {
1706                if (off==subtr_amg) {
1707                  right = left;
1708                  left = nullsv;
1709                  lr = 1;
1710                }
1711              } else {
1712                return left;
1713              }
1714            }
1715            break;
1716          case neg_amg:
1717            if ((cv = cvp[off=subtr_amg])) {
1718              right = left;
1719              left = sv_2mortal(newSViv(0));
1720              lr = 1;
1721            }
1722            break;
1723          case int_amg:
1724          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1725              /* FAIL safe */
1726              return NULL;       /* Delegate operation to standard mechanisms. */
1727              break;
1728          case to_sv_amg:
1729          case to_av_amg:
1730          case to_hv_amg:
1731          case to_gv_amg:
1732          case to_cv_amg:
1733              /* FAIL safe */
1734              return left;       /* Delegate operation to standard mechanisms. */
1735              break;
1736          default:
1737            goto not_found;
1738          }
1739          if (!cv) goto not_found;
1740     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1741                && (stash = SvSTASH(SvRV(right)))
1742                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1743                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1744                           ? (amtp = (AMT*)mg->mg_ptr)->table
1745                           : (CV **) NULL))
1746                && (cv = cvp[off=method])) { /* Method for right
1747                                              * argument found */
1748       lr=1;
1749     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1750                  && (cvp=ocvp) && (lr = -1))
1751                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1752                && !(flags & AMGf_unary)) {
1753                                 /* We look for substitution for
1754                                  * comparison operations and
1755                                  * concatenation */
1756       if (method==concat_amg || method==concat_ass_amg
1757           || method==repeat_amg || method==repeat_ass_amg) {
1758         return NULL;            /* Delegate operation to string conversion */
1759       }
1760       off = -1;
1761       switch (method) {
1762          case lt_amg:
1763          case le_amg:
1764          case gt_amg:
1765          case ge_amg:
1766          case eq_amg:
1767          case ne_amg:
1768            postpr = 1; off=ncmp_amg; break;
1769          case slt_amg:
1770          case sle_amg:
1771          case sgt_amg:
1772          case sge_amg:
1773          case seq_amg:
1774          case sne_amg:
1775            postpr = 1; off=scmp_amg; break;
1776          }
1777       if (off != -1) cv = cvp[off];
1778       if (!cv) {
1779         goto not_found;
1780       }
1781     } else {
1782     not_found:                  /* No method found, either report or croak */
1783       switch (method) {
1784          case to_sv_amg:
1785          case to_av_amg:
1786          case to_hv_amg:
1787          case to_gv_amg:
1788          case to_cv_amg:
1789              /* FAIL safe */
1790              return left;       /* Delegate operation to standard mechanisms. */
1791              break;
1792       }
1793       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1794         notfound = 1; lr = -1;
1795       } else if (cvp && (cv=cvp[nomethod_amg])) {
1796         notfound = 1; lr = 1;
1797       } else {
1798         SV *msg;
1799         if (off==-1) off=method;
1800         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1801                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1802                       AMG_id2name(method + assignshift),
1803                       (flags & AMGf_unary ? " " : "\n\tleft "),
1804                       SvAMAGIC(left)?
1805                         "in overloaded package ":
1806                         "has no overloaded magic",
1807                       SvAMAGIC(left)?
1808                         HvNAME_get(SvSTASH(SvRV(left))):
1809                         "",
1810                       SvAMAGIC(right)?
1811                         ",\n\tright argument in overloaded package ":
1812                         (flags & AMGf_unary
1813                          ? ""
1814                          : ",\n\tright argument has no overloaded magic"),
1815                       SvAMAGIC(right)?
1816                         HvNAME_get(SvSTASH(SvRV(right))):
1817                         ""));
1818         if (amtp && amtp->fallback >= AMGfallYES) {
1819           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1820         } else {
1821           Perl_croak(aTHX_ "%"SVf, msg);
1822         }
1823         return NULL;
1824       }
1825       force_cpy = force_cpy || assign;
1826     }
1827   }
1828 #ifdef DEBUGGING
1829   if (!notfound) {
1830     DEBUG_o(Perl_deb(aTHX_
1831                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1832                      AMG_id2name(off),
1833                      method+assignshift==off? "" :
1834                      " (initially \"",
1835                      method+assignshift==off? "" :
1836                      AMG_id2name(method+assignshift),
1837                      method+assignshift==off? "" : "\")",
1838                      flags & AMGf_unary? "" :
1839                      lr==1 ? " for right argument": " for left argument",
1840                      flags & AMGf_unary? " for argument" : "",
1841                      stash ? HvNAME_get(stash) : "null",
1842                      fl? ",\n\tassignment variant used": "") );
1843   }
1844 #endif
1845     /* Since we use shallow copy during assignment, we need
1846      * to dublicate the contents, probably calling user-supplied
1847      * version of copy operator
1848      */
1849     /* We need to copy in following cases:
1850      * a) Assignment form was called.
1851      *          assignshift==1,  assign==T, method + 1 == off
1852      * b) Increment or decrement, called directly.
1853      *          assignshift==0,  assign==0, method + 0 == off
1854      * c) Increment or decrement, translated to assignment add/subtr.
1855      *          assignshift==0,  assign==T,
1856      *          force_cpy == T
1857      * d) Increment or decrement, translated to nomethod.
1858      *          assignshift==0,  assign==0,
1859      *          force_cpy == T
1860      * e) Assignment form translated to nomethod.
1861      *          assignshift==1,  assign==T, method + 1 != off
1862      *          force_cpy == T
1863      */
1864     /*  off is method, method+assignshift, or a result of opcode substitution.
1865      *  In the latter case assignshift==0, so only notfound case is important.
1866      */
1867   if (( (method + assignshift == off)
1868         && (assign || (method == inc_amg) || (method == dec_amg)))
1869       || force_cpy)
1870     RvDEEPCP(left);
1871   {
1872     dSP;
1873     BINOP myop;
1874     SV* res;
1875     const bool oldcatch = CATCH_GET;
1876
1877     CATCH_SET(TRUE);
1878     Zero(&myop, 1, BINOP);
1879     myop.op_last = (OP *) &myop;
1880     myop.op_next = NULL;
1881     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1882
1883     PUSHSTACKi(PERLSI_OVERLOAD);
1884     ENTER;
1885     SAVEOP();
1886     PL_op = (OP *) &myop;
1887     if (PERLDB_SUB && PL_curstash != PL_debstash)
1888         PL_op->op_private |= OPpENTERSUB_DB;
1889     PUTBACK;
1890     pp_pushmark();
1891
1892     EXTEND(SP, notfound + 5);
1893     PUSHs(lr>0? right: left);
1894     PUSHs(lr>0? left: right);
1895     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1896     if (notfound) {
1897       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1898     }
1899     PUSHs((SV*)cv);
1900     PUTBACK;
1901
1902     if ((PL_op = Perl_pp_entersub(aTHX)))
1903       CALLRUNOPS(aTHX);
1904     LEAVE;
1905     SPAGAIN;
1906
1907     res=POPs;
1908     PUTBACK;
1909     POPSTACK;
1910     CATCH_SET(oldcatch);
1911
1912     if (postpr) {
1913       int ans;
1914       switch (method) {
1915       case le_amg:
1916       case sle_amg:
1917         ans=SvIV(res)<=0; break;
1918       case lt_amg:
1919       case slt_amg:
1920         ans=SvIV(res)<0; break;
1921       case ge_amg:
1922       case sge_amg:
1923         ans=SvIV(res)>=0; break;
1924       case gt_amg:
1925       case sgt_amg:
1926         ans=SvIV(res)>0; break;
1927       case eq_amg:
1928       case seq_amg:
1929         ans=SvIV(res)==0; break;
1930       case ne_amg:
1931       case sne_amg:
1932         ans=SvIV(res)!=0; break;
1933       case inc_amg:
1934       case dec_amg:
1935         SvSetSV(left,res); return left;
1936       case not_amg:
1937         ans=!SvTRUE(res); break;
1938       default:
1939         ans=0; break;
1940       }
1941       return boolSV(ans);
1942     } else if (method==copy_amg) {
1943       if (!SvROK(res)) {
1944         Perl_croak(aTHX_ "Copy method did not return a reference");
1945       }
1946       return SvREFCNT_inc(SvRV(res));
1947     } else {
1948       return res;
1949     }
1950   }
1951 }
1952
1953 /*
1954 =for apidoc is_gv_magical_sv
1955
1956 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1957
1958 =cut
1959 */
1960
1961 bool
1962 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1963 {
1964     STRLEN len;
1965     const char * const temp = SvPV_const(name, len);
1966     return is_gv_magical(temp, len, flags);
1967 }
1968
1969 /*
1970 =for apidoc is_gv_magical
1971
1972 Returns C<TRUE> if given the name of a magical GV.
1973
1974 Currently only useful internally when determining if a GV should be
1975 created even in rvalue contexts.
1976
1977 C<flags> is not used at present but available for future extension to
1978 allow selecting particular classes of magical variable.
1979
1980 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1981 This assumption is met by all callers within the perl core, which all pass
1982 pointers returned by SvPV.
1983
1984 =cut
1985 */
1986 bool
1987 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1988 {
1989     PERL_UNUSED_CONTEXT;
1990     PERL_UNUSED_ARG(flags);
1991
1992     if (len > 1) {
1993         const char * const name1 = name + 1;
1994         switch (*name) {
1995         case 'I':
1996             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1997                 goto yes;
1998             break;
1999         case 'O':
2000             if (len == 8 && strEQ(name1, "VERLOAD"))
2001                 goto yes;
2002             break;
2003         case 'S':
2004             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2005                 goto yes;
2006             break;
2007             /* Using ${^...} variables is likely to be sufficiently rare that
2008                it seems sensible to avoid the space hit of also checking the
2009                length.  */
2010         case '\017':   /* ${^OPEN} */
2011             if (strEQ(name1, "PEN"))
2012                 goto yes;
2013             break;
2014         case '\024':   /* ${^TAINT} */
2015             if (strEQ(name1, "AINT"))
2016                 goto yes;
2017             break;
2018         case '\025':    /* ${^UNICODE} */
2019             if (strEQ(name1, "NICODE"))
2020                 goto yes;
2021             if (strEQ(name1, "TF8LOCALE"))
2022                 goto yes;
2023             break;
2024         case '\027':   /* ${^WARNING_BITS} */
2025             if (strEQ(name1, "ARNING_BITS"))
2026                 goto yes;
2027             break;
2028         case '1':
2029         case '2':
2030         case '3':
2031         case '4':
2032         case '5':
2033         case '6':
2034         case '7':
2035         case '8':
2036         case '9':
2037         {
2038             const char *end = name + len;
2039             while (--end > name) {
2040                 if (!isDIGIT(*end))
2041                     return FALSE;
2042             }
2043             goto yes;
2044         }
2045         }
2046     } else {
2047         /* Because we're already assuming that name is NUL terminated
2048            below, we can treat an empty name as "\0"  */
2049         switch (*name) {
2050         case '&':
2051         case '`':
2052         case '\'':
2053         case ':':
2054         case '?':
2055         case '!':
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 '\001':   /* $^A */
2076         case '\003':   /* $^C */
2077         case '\004':   /* $^D */
2078         case '\005':   /* $^E */
2079         case '\006':   /* $^F */
2080         case '\010':   /* $^H */
2081         case '\011':   /* $^I, NOT \t in EBCDIC */
2082         case '\014':   /* $^L */
2083         case '\016':   /* $^N */
2084         case '\017':   /* $^O */
2085         case '\020':   /* $^P */
2086         case '\023':   /* $^S */
2087         case '\024':   /* $^T */
2088         case '\026':   /* $^V */
2089         case '\027':   /* $^W */
2090         case '1':
2091         case '2':
2092         case '3':
2093         case '4':
2094         case '5':
2095         case '6':
2096         case '7':
2097         case '8':
2098         case '9':
2099         yes:
2100             return TRUE;
2101         default:
2102             break;
2103         }
2104     }
2105     return FALSE;
2106 }
2107
2108 void
2109 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2110 {
2111     dVAR;
2112     U32 hash;
2113
2114     PERL_UNUSED_ARG(flags);
2115
2116     if (len > I32_MAX)
2117         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2118
2119     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2120         unshare_hek(GvNAME_HEK(gv));
2121     }
2122
2123     PERL_HASH(hash, name, len);
2124     GvNAME_HEK(gv) = name ? share_hek(name, len, hash) : 0;
2125 }
2126
2127 /*
2128  * Local variables:
2129  * c-indentation-style: bsd
2130  * c-basic-offset: 4
2131  * indent-tabs-mode: t
2132  * End:
2133  *
2134  * ex: set ts=8 sts=4 sw=4 noet:
2135  */