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