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