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, Nullch, 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 = flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND;
 766     const char *const name_end = nambeg + full_len;
 767     const char *const name_em1 = name_end - 1;
 768
 769     if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
 770         /* accidental stringify on a GV? */
 771         name++;
 772     }
 773
 774     for (name_cursor = name; name_cursor < name_end; name_cursor++) {
 775         if ((*name_cursor == ':' && name_cursor < name_em1
 776              && name_cursor[1] == ':')
 777             || (*name_cursor == '\'' && name_cursor[1]))
 778         {
 779             if (!stash)
 780                 stash = PL_defstash;
 781             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 782                 return Nullgv;
 783
 784             len = name_cursor - name;
 785             if (len > 0) {
 786                 char smallbuf[128];
 787                 char *tmpbuf;
 788
 789                 if (len + 3 < sizeof (smallbuf))
 790                     tmpbuf = smallbuf;
 791                 else
 792                     Newx(tmpbuf, len+3, char);
 793                 Copy(name, tmpbuf, len, char);
 794                 tmpbuf[len++] = ':';
 795                 tmpbuf[len++] = ':';
 796                 tmpbuf[len] = '\0';
 797                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 798                 gv = gvp ? *gvp : Nullgv;
 799                 if (gv && gv != (GV*)&PL_sv_undef) {
 800                     if (SvTYPE(gv) != SVt_PVGV)
 801                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 802                     else
 803                         GvMULTI_on(gv);
 804                 }
 805                 if (tmpbuf != smallbuf)
 806                     Safefree(tmpbuf);
 807                 if (!gv || gv == (GV*)&PL_sv_undef)
 808                     return Nullgv;
 809
 810                 if (!(stash = GvHV(gv)))
 811                     stash = GvHV(gv) = newHV();
 812
 813                 if (!HvNAME_get(stash))
 814                     hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
 815             }
 816
 817             if (*name_cursor == ':')
 818                 name_cursor++;
 819             name_cursor++;
 820             name = name_cursor;
 821             if (name == name_end)
 822                 return gv ? gv : (GV*)*hv_fetchs(PL_defstash, "main::", TRUE);
 823         }
 824     }
 825     len = name_cursor - name;
 826
 827     /* No stash in name, so see how we can default */
 828
 829     if (!stash) {
 830         if (len && isIDFIRST_lazy(name)) {
 831             bool global = FALSE;
 832
 833             switch (len) {
 834             case 1:
 835                 if (*name == '_')
 836                     global = TRUE;
 837                 break;
 838             case 3:
 839                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
 840                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
 841                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
 842                     global = TRUE;
 843                 break;
 844             case 4:
 845                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
 846                     && name[3] == 'V')
 847                     global = TRUE;
 848                 break;
 849             case 5:
 850                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
 851                     && name[3] == 'I' && name[4] == 'N')
 852                     global = TRUE;
 853                 break;
 854             case 6:
 855                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
 856                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
 857                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
 858                     global = TRUE;
 859                 break;
 860             case 7:
 861                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
 862                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
 863                     && name[6] == 'T')
 864                     global = TRUE;
 865                 break;
 866             }
 867
 868             if (global)
 869                 stash = PL_defstash;
 870             else if (IN_PERL_COMPILETIME) {
 871                 stash = PL_curstash;
 872                 if (add && (PL_hints & HINT_STRICT_VARS) &&
 873                     sv_type != SVt_PVCV &&
 874                     sv_type != SVt_PVGV &&
 875                     sv_type != SVt_PVFM &&
 876                     sv_type != SVt_PVIO &&
 877                     !(len == 1 && sv_type == SVt_PV &&
 878                       (*name == 'a' || *name == 'b')) )
 879                 {
 880                     gvp = (GV**)hv_fetch(stash,name,len,0);
 881                     if (!gvp ||
 882                         *gvp == (GV*)&PL_sv_undef ||
 883                         SvTYPE(*gvp) != SVt_PVGV)
 884                     {
 885                         stash = 0;
 886                     }
 887                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
 888                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
 889                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 890                     {
 891                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 892                             sv_type == SVt_PVAV ? '@' :
 893                             sv_type == SVt_PVHV ? '%' : '$',
 894                             name);
 895                         if (GvCVu(*gvp))
 896                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
 897                         stash = 0;
 898                     }
 899                 }
 900             }
 901             else
 902                 stash = CopSTASH(PL_curcop);
 903         }
 904         else
 905             stash = PL_defstash;
 906     }
 907
 908     /* By this point we should have a stash and a name */
 909
 910     if (!stash) {
 911         if (add) {
 912             SV * const err = Perl_mess(aTHX_
 913                  "Global symbol \"%s%s\" requires explicit package name",
 914                  (sv_type == SVt_PV ? "$"
 915                   : sv_type == SVt_PVAV ? "@"
 916                   : sv_type == SVt_PVHV ? "%"
 917                   : ""), name);
 918             if (USE_UTF8_IN_NAMES)
 919                 SvUTF8_on(err);
 920             qerror(err);
 921             stash = GvHV(gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV));
 922         }
 923         else
 924             return Nullgv;
 925     }
 926
 927     if (!SvREFCNT(stash))       /* symbol table under destruction */
 928         return Nullgv;
 929
 930     gvp = (GV**)hv_fetch(stash,name,len,add);
 931     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 932         return Nullgv;
 933     gv = *gvp;
 934     if (SvTYPE(gv) == SVt_PVGV) {
 935         if (add) {
 936             GvMULTI_on(gv);
 937             gv_init_sv(gv, sv_type);
 938             if (*name=='!' && sv_type == SVt_PVHV && len==1)
 939                 require_errno(gv);
 940         }
 941         return gv;
 942     } else if (no_init) {
 943         return gv;
 944     } else if (no_expand && SvROK(gv)) {
 945         return gv;
 946     }
 947
 948     /* Adding a new symbol */
 949
 950     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
 951         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
 952     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
 953     gv_init_sv(gv, sv_type);
 954
 955     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
 956                                             : (PL_dowarn & G_WARN_ON ) ) )
 957         GvMULTI_on(gv) ;
 958
 959     /* set up magic where warranted */
 960     if (len > 1) {
 961 #ifndef EBCDIC
 962         if (*name > 'V' ) {
 963             /* Nothing else to do.
 964                The compiler will probably turn the switch statement into a
 965                branch table. Make sure we avoid even that small overhead for
 966                the common case of lower case variable names.  */
 967         } else
 968 #endif
 969         {
 970             const char * const name2 = name + 1;
 971             switch (*name) {
 972             case 'A':
 973                 if (strEQ(name2, "RGV")) {
 974                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 975                 }
 976                 break;
 977             case 'E':
 978                 if (strnEQ(name2, "XPORT", 5))
 979                     GvMULTI_on(gv);
 980                 break;
 981             case 'I':
 982                 if (strEQ(name2, "SA")) {
 983                     AV* const av = GvAVn(gv);
 984                     GvMULTI_on(gv);
 985                     sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
 986                     /* NOTE: No support for tied ISA */
 987                     if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 988                         && AvFILLp(av) == -1)
 989                         {
 990                             const char *pname;
 991                             av_push(av, newSVpvn(pname = "NDBM_File",9));
 992                             gv_stashpvn(pname, 9, TRUE);
 993                             av_push(av, newSVpvn(pname = "DB_File",7));
 994                             gv_stashpvn(pname, 7, TRUE);
 995                             av_push(av, newSVpvn(pname = "GDBM_File",9));
 996                             gv_stashpvn(pname, 9, TRUE);
 997                             av_push(av, newSVpvn(pname = "SDBM_File",9));
 998                             gv_stashpvn(pname, 9, TRUE);
 999                             av_push(av, newSVpvn(pname = "ODBM_File",9));
1000                             gv_stashpvn(pname, 9, TRUE);
1001                         }
1002                 }
1003                 break;
1004             case 'O':
1005                 if (strEQ(name2, "VERLOAD")) {
1006                     HV* const hv = GvHVn(gv);
1007                     GvMULTI_on(gv);
1008                     hv_magic(hv, Nullgv, PERL_MAGIC_overload);
1009                 }
1010                 break;
1011             case 'S':
1012                 if (strEQ(name2, "IG")) {
1013                     HV *hv;
1014                     I32 i;
1015                     if (!PL_psig_ptr) {
1016                         Newxz(PL_psig_ptr,  SIG_SIZE, SV*);
1017                         Newxz(PL_psig_name, SIG_SIZE, SV*);
1018                         Newxz(PL_psig_pend, SIG_SIZE, int);
1019                     }
1020                     GvMULTI_on(gv);
1021                     hv = GvHVn(gv);
1022                     hv_magic(hv, Nullgv, PERL_MAGIC_sig);
1023                     for (i = 1; i < SIG_SIZE; i++) {
1024                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1025                         if (init)
1026                             sv_setsv(*init, &PL_sv_undef);
1027                         PL_psig_ptr[i] = 0;
1028                         PL_psig_name[i] = 0;
1029                         PL_psig_pend[i] = 0;
1030                     }
1031                 }
1032                 break;
1033             case 'V':
1034                 if (strEQ(name2, "ERSION"))
1035                     GvMULTI_on(gv);
1036                 break;
1037             case '\003':        /* $^CHILD_ERROR_NATIVE */
1038                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1039                     goto magicalize;
1040                 break;
1041             case '\005':        /* $^ENCODING */
1042                 if (strEQ(name2, "NCODING"))
1043                     goto magicalize;
1044                 break;
1045             case '\017':        /* $^OPEN */
1046                 if (strEQ(name2, "PEN"))
1047                     goto magicalize;
1048                 break;
1049             case '\024':        /* ${^TAINT} */
1050                 if (strEQ(name2, "AINT"))
1051                     goto ro_magicalize;
1052                 break;
1053             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1054                 if (strEQ(name2, "NICODE"))
1055                     goto ro_magicalize;
1056                 if (strEQ(name2, "TF8LOCALE"))
1057                     goto ro_magicalize;
1058                 break;
1059             case '\027':        /* $^WARNING_BITS */
1060                 if (strEQ(name2, "ARNING_BITS"))
1061                     goto magicalize;
1062                 break;
1063             case '1':
1064             case '2':
1065             case '3':
1066             case '4':
1067             case '5':
1068             case '6':
1069             case '7':
1070             case '8':
1071             case '9':
1072             {
1073                 /* ensures variable is only digits */
1074                 /* ${"1foo"} fails this test (and is thus writeable) */
1075                 /* added by japhy, but borrowed from is_gv_magical */
1076                 const char *end = name + len;
1077                 while (--end > name) {
1078                     if (!isDIGIT(*end)) return gv;
1079                 }
1080                 goto ro_magicalize;
1081             }
1082             }
1083         }
1084     } else {
1085         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1086            be case '\0' in this switch statement (ie a default case)  */
1087         switch (*name) {
1088         case '&':
1089         case '`':
1090         case '\'':
1091             if (
1092                 sv_type == SVt_PVAV ||
1093                 sv_type == SVt_PVHV ||
1094                 sv_type == SVt_PVCV ||
1095                 sv_type == SVt_PVFM ||
1096                 sv_type == SVt_PVIO
1097                 ) { break; }
1098             PL_sawampersand = TRUE;
1099             goto ro_magicalize;
1100
1101         case ':':
1102             sv_setpv(GvSVn(gv),PL_chopset);
1103             goto magicalize;
1104
1105         case '?':
1106 #ifdef COMPLEX_STATUS
1107             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1108 #endif
1109             goto magicalize;
1110
1111         case '!':
1112
1113             /* If %! has been used, automatically load Errno.pm.
1114                The require will itself set errno, so in order to
1115                preserve its value we have to set up the magic
1116                now (rather than going to magicalize)
1117             */
1118
1119             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1120
1121             if (sv_type == SVt_PVHV)
1122                 require_errno(gv);
1123
1124             break;
1125         case '-':
1126         {
1127             AV* const av = GvAVn(gv);
1128             sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
1129             SvREADONLY_on(av);
1130             goto magicalize;
1131         }
1132         case '*':
1133         case '#':
1134             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1135                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1136                             "$%c is no longer supported", *name);
1137             break;
1138         case '|':
1139             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1140             goto magicalize;
1141
1142         case '+':
1143         {
1144             AV* const av = GvAVn(gv);
1145             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1146             SvREADONLY_on(av);
1147             /* FALL THROUGH */
1148         }
1149         case '\023':    /* $^S */
1150         case '1':
1151         case '2':
1152         case '3':
1153         case '4':
1154         case '5':
1155         case '6':
1156         case '7':
1157         case '8':
1158         case '9':
1159         ro_magicalize:
1160             SvREADONLY_on(GvSVn(gv));
1161             /* FALL THROUGH */
1162         case '[':
1163         case '^':
1164         case '~':
1165         case '=':
1166         case '%':
1167         case '.':
1168         case '(':
1169         case ')':
1170         case '<':
1171         case '>':
1172         case ',':
1173         case '\\':
1174         case '/':
1175         case '\001':    /* $^A */
1176         case '\003':    /* $^C */
1177         case '\004':    /* $^D */
1178         case '\005':    /* $^E */
1179         case '\006':    /* $^F */
1180         case '\010':    /* $^H */
1181         case '\011':    /* $^I, NOT \t in EBCDIC */
1182         case '\016':    /* $^N */
1183         case '\017':    /* $^O */
1184         case '\020':    /* $^P */
1185         case '\024':    /* $^T */
1186         case '\027':    /* $^W */
1187         magicalize:
1188             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1189             break;
1190
1191         case '\014':    /* $^L */
1192             sv_setpvn(GvSVn(gv),"\f",1);
1193             PL_formfeed = GvSVn(gv);
1194             break;
1195         case ';':
1196             sv_setpvn(GvSVn(gv),"\034",1);
1197             break;
1198         case ']':
1199         {
1200             SV * const sv = GvSVn(gv);
1201             if (!sv_derived_from(PL_patchlevel, "version"))
1202                 upg_version(PL_patchlevel);
1203             GvSV(gv) = vnumify(PL_patchlevel);
1204             SvREADONLY_on(GvSV(gv));
1205             SvREFCNT_dec(sv);
1206         }
1207         break;
1208         case '\026':    /* $^V */
1209         {
1210             SV * const sv = GvSVn(gv);
1211             GvSV(gv) = new_version(PL_patchlevel);
1212             SvREADONLY_on(GvSV(gv));
1213             SvREFCNT_dec(sv);
1214         }
1215         break;
1216         }
1217     }
1218     return gv;
1219 }
1220
1221 void
1222 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1223 {
1224     const char *name;
1225     STRLEN namelen;
1226     const HV * const hv = GvSTASH(gv);
1227     if (!hv) {
1228         SvOK_off(sv);
1229         return;
1230     }
1231     sv_setpv(sv, prefix ? prefix : "");
1232
1233     name = HvNAME_get(hv);
1234     if (name) {
1235         namelen = HvNAMELEN_get(hv);
1236     } else {
1237         name = "__ANON__";
1238         namelen = 8;
1239     }
1240
1241     if (keepmain || strNE(name, "main")) {
1242         sv_catpvn(sv,name,namelen);
1243         sv_catpvs(sv,"::");
1244     }
1245     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1246 }
1247
1248 void
1249 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1250 {
1251     const GV * const egv = GvEGV(gv);
1252     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1253 }
1254
1255 IO *
1256 Perl_newIO(pTHX)
1257 {
1258     dVAR;
1259     GV *iogv;
1260     IO * const io = (IO*)newSV(0);
1261
1262     sv_upgrade((SV *)io,SVt_PVIO);
1263     /* This used to read SvREFCNT(io) = 1;
1264        It's not clear why the reference count needed an explicit reset. NWC
1265     */
1266     assert (SvREFCNT(io) == 1);
1267     SvOBJECT_on(io);
1268     /* Clear the stashcache because a new IO could overrule a package name */
1269     hv_clear(PL_stashcache);
1270     iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1271     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1272     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1273       iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1274     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1275     return io;
1276 }
1277
1278 void
1279 Perl_gv_check(pTHX_ HV *stash)
1280 {
1281     dVAR;
1282     register I32 i;
1283
1284     if (!HvARRAY(stash))
1285         return;
1286     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1287         const HE *entry;
1288         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1289             register GV *gv;
1290             HV *hv;
1291             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1292                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1293             {
1294                 if (hv != PL_defstash && hv != stash)
1295                      gv_check(hv);              /* nested package */
1296             }
1297             else if (isALPHA(*HeKEY(entry))) {
1298                 const char *file;
1299                 gv = (GV*)HeVAL(entry);
1300                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1301                     continue;
1302                 file = GvFILE(gv);
1303                 /* performance hack: if filename is absolute and it's a standard
1304                  * module, don't bother warning */
1305 #ifdef MACOS_TRADITIONAL
1306 #   define LIB_COMPONENT ":lib:"
1307 #else
1308 #   define LIB_COMPONENT "/lib/"
1309 #endif
1310                 if (file
1311                     && PERL_FILE_IS_ABSOLUTE(file)
1312                     && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1313                 {
1314                     continue;
1315                 }
1316                 CopLINE_set(PL_curcop, GvLINE(gv));
1317 #ifdef USE_ITHREADS
1318                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1319 #else
1320                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1321 #endif
1322                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1323                         "Name \"%s::%s\" used only once: possible typo",
1324                         HvNAME_get(stash), GvNAME(gv));
1325             }
1326         }
1327     }
1328 }
1329
1330 GV *
1331 Perl_newGVgen(pTHX_ const char *pack)
1332 {
1333     dVAR;
1334     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1335                       TRUE, SVt_PVGV);
1336 }
1337
1338 /* hopefully this is only called on local symbol table entries */
1339
1340 GP*
1341 Perl_gp_ref(pTHX_ GP *gp)
1342 {
1343     dVAR;
1344     if (!gp)
1345         return (GP*)NULL;
1346     gp->gp_refcnt++;
1347     if (gp->gp_cv) {
1348         if (gp->gp_cvgen) {
1349             /* multi-named GPs cannot be used for method cache */
1350             SvREFCNT_dec(gp->gp_cv);
1351             gp->gp_cv = Nullcv;
1352             gp->gp_cvgen = 0;
1353         }
1354         else {
1355             /* Adding a new name to a subroutine invalidates method cache */
1356             PL_sub_generation++;
1357         }
1358     }
1359     return gp;
1360 }
1361
1362 void
1363 Perl_gp_free(pTHX_ GV *gv)
1364 {
1365     dVAR;
1366     GP* gp;
1367
1368     if (!gv || !(gp = GvGP(gv)))
1369         return;
1370     if (gp->gp_refcnt == 0) {
1371         if (ckWARN_d(WARN_INTERNAL))
1372             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1373                         "Attempt to free unreferenced glob pointers"
1374                         pTHX__FORMAT pTHX__VALUE);
1375         return;
1376     }
1377     if (gp->gp_cv) {
1378         /* Deleting the name of a subroutine invalidates method cache */
1379         PL_sub_generation++;
1380     }
1381     if (--gp->gp_refcnt > 0) {
1382         if (gp->gp_egv == gv)
1383             gp->gp_egv = 0;
1384         return;
1385     }
1386
1387     if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1388     if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1389     /* FIXME - another reference loop GV -> symtab -> GV ?
1390        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1391     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1392         const char *hvname = HvNAME_get(gp->gp_hv);
1393         if (PL_stashcache && hvname)
1394             hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1395                       G_DISCARD);
1396         SvREFCNT_dec(gp->gp_hv);
1397     }
1398     if (gp->gp_io)   SvREFCNT_dec(gp->gp_io);
1399     if (gp->gp_cv)   SvREFCNT_dec(gp->gp_cv);
1400     if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1401
1402     Safefree(gp);
1403     GvGP(gv) = 0;
1404 }
1405
1406 int
1407 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1408 {
1409     AMT * const amtp = (AMT*)mg->mg_ptr;
1410     PERL_UNUSED_ARG(sv);
1411
1412     if (amtp && AMT_AMAGIC(amtp)) {
1413         int i;
1414         for (i = 1; i < NofAMmeth; i++) {
1415             CV * const cv = amtp->table[i];
1416             if (cv != Nullcv) {
1417                 SvREFCNT_dec((SV *) cv);
1418                 amtp->table[i] = Nullcv;
1419             }
1420         }
1421     }
1422  return 0;
1423 }
1424
1425 /* Updates and caches the CV's */
1426
1427 bool
1428 Perl_Gv_AMupdate(pTHX_ HV *stash)
1429 {
1430   dVAR;
1431   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1432   AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1433   AMT amt;
1434
1435   if (mg && amtp->was_ok_am == PL_amagic_generation
1436       && amtp->was_ok_sub == PL_sub_generation)
1437       return (bool)AMT_OVERLOADED(amtp);
1438   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1439
1440   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1441
1442   Zero(&amt,1,AMT);
1443   amt.was_ok_am = PL_amagic_generation;
1444   amt.was_ok_sub = PL_sub_generation;
1445   amt.fallback = AMGfallNO;
1446   amt.flags = 0;
1447
1448   {
1449     int filled = 0, have_ovl = 0;
1450     int i, lim = 1;
1451
1452     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1453
1454     /* Try to find via inheritance. */
1455     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1456     SV * const sv = gv ? GvSV(gv) : NULL;
1457     CV* cv;
1458
1459     if (!gv)
1460         lim = DESTROY_amg;              /* Skip overloading entries. */
1461 #ifdef PERL_DONT_CREATE_GVSV
1462     else if (!sv) {
1463         /* Equivalent to !SvTRUE and !SvOK  */
1464     }
1465 #endif
1466     else if (SvTRUE(sv))
1467         amt.fallback=AMGfallYES;
1468     else if (SvOK(sv))
1469         amt.fallback=AMGfallNEVER;
1470
1471     for (i = 1; i < lim; i++)
1472         amt.table[i] = Nullcv;
1473     for (; i < NofAMmeth; i++) {
1474         const char * const cooky = PL_AMG_names[i];
1475         /* Human-readable form, for debugging: */
1476         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1477         const STRLEN l = strlen(cooky);
1478
1479         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1480                      cp, HvNAME_get(stash)) );
1481         /* don't fill the cache while looking up!
1482            Creation of inheritance stubs in intermediate packages may
1483            conflict with the logic of runtime method substitution.
1484            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1485            then we could have created stubs for "(+0" in A and C too.
1486            But if B overloads "bool", we may want to use it for
1487            numifying instead of C's "+0". */
1488         if (i >= DESTROY_amg)
1489             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1490         else                            /* Autoload taken care of below */
1491             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1492         cv = 0;
1493         if (gv && (cv = GvCV(gv))) {
1494             const char *hvname;
1495             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1496                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1497                 /* This is a hack to support autoloading..., while
1498                    knowing *which* methods were declared as overloaded. */
1499                 /* GvSV contains the name of the method. */
1500                 GV *ngv = NULL;
1501                 SV *gvsv = GvSV(gv);
1502
1503                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1504                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1505                              GvSV(gv), cp, hvname) );
1506                 if (!gvsv || !SvPOK(gvsv)
1507                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1508                                                        FALSE)))
1509                 {
1510                     /* Can be an import stub (created by "can"). */
1511                     const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1512                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1513                                 "in package \"%.256s\"",
1514                                (GvCVGEN(gv) ? "Stub found while resolving"
1515                                 : "Can't resolve"),
1516                                name, cp, hvname);
1517                 }
1518                 cv = GvCV(gv = ngv);
1519             }
1520             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1521                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1522                          GvNAME(CvGV(cv))) );
1523             filled = 1;
1524             if (i < DESTROY_amg)
1525                 have_ovl = 1;
1526         } else if (gv) {                /* Autoloaded... */
1527             cv = (CV*)gv;
1528             filled = 1;
1529         }
1530         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1531     }
1532     if (filled) {
1533       AMT_AMAGIC_on(&amt);
1534       if (have_ovl)
1535           AMT_OVERLOADED_on(&amt);
1536       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1537                                                 (char*)&amt, sizeof(AMT));
1538       return have_ovl;
1539     }
1540   }
1541   /* Here we have no table: */
1542   /* no_table: */
1543   AMT_AMAGIC_off(&amt);
1544   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1545                                                 (char*)&amt, sizeof(AMTS));
1546   return FALSE;
1547 }
1548
1549
1550 CV*
1551 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1552 {
1553     dVAR;
1554     MAGIC *mg;
1555     AMT *amtp;
1556
1557     if (!stash || !HvNAME_get(stash))
1558         return Nullcv;
1559     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1560     if (!mg) {
1561       do_update:
1562         Gv_AMupdate(stash);
1563         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1564     }
1565     amtp = (AMT*)mg->mg_ptr;
1566     if ( amtp->was_ok_am != PL_amagic_generation
1567          || amtp->was_ok_sub != PL_sub_generation )
1568         goto do_update;
1569     if (AMT_AMAGIC(amtp)) {
1570         CV * const ret = amtp->table[id];
1571         if (ret && isGV(ret)) {         /* Autoloading stab */
1572             /* Passing it through may have resulted in a warning
1573                "Inherited AUTOLOAD for a non-method deprecated", since
1574                our caller is going through a function call, not a method call.
1575                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1576             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1577
1578             if (gv && GvCV(gv))
1579                 return GvCV(gv);
1580         }
1581         return ret;
1582     }
1583
1584     return Nullcv;
1585 }
1586
1587
1588 SV*
1589 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1590 {
1591   dVAR;
1592   MAGIC *mg;
1593   CV *cv=NULL;
1594   CV **cvp=NULL, **ocvp=NULL;
1595   AMT *amtp=NULL, *oamtp=NULL;
1596   int off = 0, off1, lr = 0, notfound = 0;
1597   int postpr = 0, force_cpy = 0;
1598   int assign = AMGf_assign & flags;
1599   const int assignshift = assign ? 1 : 0;
1600 #ifdef DEBUGGING
1601   int fl=0;
1602 #endif
1603   HV* stash=NULL;
1604   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1605       && (stash = SvSTASH(SvRV(left)))
1606       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1607       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1608                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1609                         : (CV **) NULL))
1610       && ((cv = cvp[off=method+assignshift])
1611           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1612                                                           * usual method */
1613                   (
1614 #ifdef DEBUGGING
1615                    fl = 1,
1616 #endif
1617                    cv = cvp[off=method])))) {
1618     lr = -1;                    /* Call method for left argument */
1619   } else {
1620     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1621       int logic;
1622
1623       /* look for substituted methods */
1624       /* In all the covered cases we should be called with assign==0. */
1625          switch (method) {
1626          case inc_amg:
1627            force_cpy = 1;
1628            if ((cv = cvp[off=add_ass_amg])
1629                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1630              right = &PL_sv_yes; lr = -1; assign = 1;
1631            }
1632            break;
1633          case dec_amg:
1634            force_cpy = 1;
1635            if ((cv = cvp[off = subtr_ass_amg])
1636                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1637              right = &PL_sv_yes; lr = -1; assign = 1;
1638            }
1639            break;
1640          case bool__amg:
1641            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1642            break;
1643          case numer_amg:
1644            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1645            break;
1646          case string_amg:
1647            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1648            break;
1649          case not_amg:
1650            (void)((cv = cvp[off=bool__amg])
1651                   || (cv = cvp[off=numer_amg])
1652                   || (cv = cvp[off=string_amg]));
1653            postpr = 1;
1654            break;
1655          case copy_amg:
1656            {
1657              /*
1658                   * SV* ref causes confusion with the interpreter variable of
1659                   * the same name
1660                   */
1661              SV* const tmpRef=SvRV(left);
1662              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1663                 /*
1664                  * Just to be extra cautious.  Maybe in some
1665                  * additional cases sv_setsv is safe, too.
1666                  */
1667                 SV* const newref = newSVsv(tmpRef);
1668                 SvOBJECT_on(newref);
1669                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1670                 return newref;
1671              }
1672            }
1673            break;
1674          case abs_amg:
1675            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1676                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1677              SV* const nullsv=sv_2mortal(newSViv(0));
1678              if (off1==lt_amg) {
1679                SV* const lessp = amagic_call(left,nullsv,
1680                                        lt_amg,AMGf_noright);
1681                logic = SvTRUE(lessp);
1682              } else {
1683                SV* const lessp = amagic_call(left,nullsv,
1684                                        ncmp_amg,AMGf_noright);
1685                logic = (SvNV(lessp) < 0);
1686              }
1687              if (logic) {
1688                if (off==subtr_amg) {
1689                  right = left;
1690                  left = nullsv;
1691                  lr = 1;
1692                }
1693              } else {
1694                return left;
1695              }
1696            }
1697            break;
1698          case neg_amg:
1699            if ((cv = cvp[off=subtr_amg])) {
1700              right = left;
1701              left = sv_2mortal(newSViv(0));
1702              lr = 1;
1703            }
1704            break;
1705          case int_amg:
1706          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1707              /* FAIL safe */
1708              return NULL;       /* Delegate operation to standard mechanisms. */
1709              break;
1710          case to_sv_amg:
1711          case to_av_amg:
1712          case to_hv_amg:
1713          case to_gv_amg:
1714          case to_cv_amg:
1715              /* FAIL safe */
1716              return left;       /* Delegate operation to standard mechanisms. */
1717              break;
1718          default:
1719            goto not_found;
1720          }
1721          if (!cv) goto not_found;
1722     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1723                && (stash = SvSTASH(SvRV(right)))
1724                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1725                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1726                           ? (amtp = (AMT*)mg->mg_ptr)->table
1727                           : (CV **) NULL))
1728                && (cv = cvp[off=method])) { /* Method for right
1729                                              * argument found */
1730       lr=1;
1731     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1732                  && (cvp=ocvp) && (lr = -1))
1733                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1734                && !(flags & AMGf_unary)) {
1735                                 /* We look for substitution for
1736                                  * comparison operations and
1737                                  * concatenation */
1738       if (method==concat_amg || method==concat_ass_amg
1739           || method==repeat_amg || method==repeat_ass_amg) {
1740         return NULL;            /* Delegate operation to string conversion */
1741       }
1742       off = -1;
1743       switch (method) {
1744          case lt_amg:
1745          case le_amg:
1746          case gt_amg:
1747          case ge_amg:
1748          case eq_amg:
1749          case ne_amg:
1750            postpr = 1; off=ncmp_amg; break;
1751          case slt_amg:
1752          case sle_amg:
1753          case sgt_amg:
1754          case sge_amg:
1755          case seq_amg:
1756          case sne_amg:
1757            postpr = 1; off=scmp_amg; break;
1758          }
1759       if (off != -1) cv = cvp[off];
1760       if (!cv) {
1761         goto not_found;
1762       }
1763     } else {
1764     not_found:                  /* No method found, either report or croak */
1765       switch (method) {
1766          case to_sv_amg:
1767          case to_av_amg:
1768          case to_hv_amg:
1769          case to_gv_amg:
1770          case to_cv_amg:
1771              /* FAIL safe */
1772              return left;       /* Delegate operation to standard mechanisms. */
1773              break;
1774       }
1775       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1776         notfound = 1; lr = -1;
1777       } else if (cvp && (cv=cvp[nomethod_amg])) {
1778         notfound = 1; lr = 1;
1779       } else {
1780         SV *msg;
1781         if (off==-1) off=method;
1782         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1783                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1784                       AMG_id2name(method + assignshift),
1785                       (flags & AMGf_unary ? " " : "\n\tleft "),
1786                       SvAMAGIC(left)?
1787                         "in overloaded package ":
1788                         "has no overloaded magic",
1789                       SvAMAGIC(left)?
1790                         HvNAME_get(SvSTASH(SvRV(left))):
1791                         "",
1792                       SvAMAGIC(right)?
1793                         ",\n\tright argument in overloaded package ":
1794                         (flags & AMGf_unary
1795                          ? ""
1796                          : ",\n\tright argument has no overloaded magic"),
1797                       SvAMAGIC(right)?
1798                         HvNAME_get(SvSTASH(SvRV(right))):
1799                         ""));
1800         if (amtp && amtp->fallback >= AMGfallYES) {
1801           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1802         } else {
1803           Perl_croak(aTHX_ "%"SVf, msg);
1804         }
1805         return NULL;
1806       }
1807       force_cpy = force_cpy || assign;
1808     }
1809   }
1810 #ifdef DEBUGGING
1811   if (!notfound) {
1812     DEBUG_o(Perl_deb(aTHX_
1813                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1814                      AMG_id2name(off),
1815                      method+assignshift==off? "" :
1816                      " (initially \"",
1817                      method+assignshift==off? "" :
1818                      AMG_id2name(method+assignshift),
1819                      method+assignshift==off? "" : "\")",
1820                      flags & AMGf_unary? "" :
1821                      lr==1 ? " for right argument": " for left argument",
1822                      flags & AMGf_unary? " for argument" : "",
1823                      stash ? HvNAME_get(stash) : "null",
1824                      fl? ",\n\tassignment variant used": "") );
1825   }
1826 #endif
1827     /* Since we use shallow copy during assignment, we need
1828      * to dublicate the contents, probably calling user-supplied
1829      * version of copy operator
1830      */
1831     /* We need to copy in following cases:
1832      * a) Assignment form was called.
1833      *          assignshift==1,  assign==T, method + 1 == off
1834      * b) Increment or decrement, called directly.
1835      *          assignshift==0,  assign==0, method + 0 == off
1836      * c) Increment or decrement, translated to assignment add/subtr.
1837      *          assignshift==0,  assign==T,
1838      *          force_cpy == T
1839      * d) Increment or decrement, translated to nomethod.
1840      *          assignshift==0,  assign==0,
1841      *          force_cpy == T
1842      * e) Assignment form translated to nomethod.
1843      *          assignshift==1,  assign==T, method + 1 != off
1844      *          force_cpy == T
1845      */
1846     /*  off is method, method+assignshift, or a result of opcode substitution.
1847      *  In the latter case assignshift==0, so only notfound case is important.
1848      */
1849   if (( (method + assignshift == off)
1850         && (assign || (method == inc_amg) || (method == dec_amg)))
1851       || force_cpy)
1852     RvDEEPCP(left);
1853   {
1854     dSP;
1855     BINOP myop;
1856     SV* res;
1857     const bool oldcatch = CATCH_GET;
1858
1859     CATCH_SET(TRUE);
1860     Zero(&myop, 1, BINOP);
1861     myop.op_last = (OP *) &myop;
1862     myop.op_next = Nullop;
1863     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1864
1865     PUSHSTACKi(PERLSI_OVERLOAD);
1866     ENTER;
1867     SAVEOP();
1868     PL_op = (OP *) &myop;
1869     if (PERLDB_SUB && PL_curstash != PL_debstash)
1870         PL_op->op_private |= OPpENTERSUB_DB;
1871     PUTBACK;
1872     pp_pushmark();
1873
1874     EXTEND(SP, notfound + 5);
1875     PUSHs(lr>0? right: left);
1876     PUSHs(lr>0? left: right);
1877     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1878     if (notfound) {
1879       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1880     }
1881     PUSHs((SV*)cv);
1882     PUTBACK;
1883
1884     if ((PL_op = Perl_pp_entersub(aTHX)))
1885       CALLRUNOPS(aTHX);
1886     LEAVE;
1887     SPAGAIN;
1888
1889     res=POPs;
1890     PUTBACK;
1891     POPSTACK;
1892     CATCH_SET(oldcatch);
1893
1894     if (postpr) {
1895       int ans;
1896       switch (method) {
1897       case le_amg:
1898       case sle_amg:
1899         ans=SvIV(res)<=0; break;
1900       case lt_amg:
1901       case slt_amg:
1902         ans=SvIV(res)<0; break;
1903       case ge_amg:
1904       case sge_amg:
1905         ans=SvIV(res)>=0; break;
1906       case gt_amg:
1907       case sgt_amg:
1908         ans=SvIV(res)>0; break;
1909       case eq_amg:
1910       case seq_amg:
1911         ans=SvIV(res)==0; break;
1912       case ne_amg:
1913       case sne_amg:
1914         ans=SvIV(res)!=0; break;
1915       case inc_amg:
1916       case dec_amg:
1917         SvSetSV(left,res); return left;
1918       case not_amg:
1919         ans=!SvTRUE(res); break;
1920       default:
1921         ans=0; break;
1922       }
1923       return boolSV(ans);
1924     } else if (method==copy_amg) {
1925       if (!SvROK(res)) {
1926         Perl_croak(aTHX_ "Copy method did not return a reference");
1927       }
1928       return SvREFCNT_inc(SvRV(res));
1929     } else {
1930       return res;
1931     }
1932   }
1933 }
1934
1935 /*
1936 =for apidoc is_gv_magical_sv
1937
1938 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1939
1940 =cut
1941 */
1942
1943 bool
1944 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1945 {
1946     STRLEN len;
1947     const char * const temp = SvPV_const(name, len);
1948     return is_gv_magical(temp, len, flags);
1949 }
1950
1951 /*
1952 =for apidoc is_gv_magical
1953
1954 Returns C<TRUE> if given the name of a magical GV.
1955
1956 Currently only useful internally when determining if a GV should be
1957 created even in rvalue contexts.
1958
1959 C<flags> is not used at present but available for future extension to
1960 allow selecting particular classes of magical variable.
1961
1962 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1963 This assumption is met by all callers within the perl core, which all pass
1964 pointers returned by SvPV.
1965
1966 =cut
1967 */
1968 bool
1969 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1970 {
1971     PERL_UNUSED_ARG(flags);
1972
1973     if (len > 1) {
1974         const char * const name1 = name + 1;
1975         switch (*name) {
1976         case 'I':
1977             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1978                 goto yes;
1979             break;
1980         case 'O':
1981             if (len == 8 && strEQ(name1, "VERLOAD"))
1982                 goto yes;
1983             break;
1984         case 'S':
1985             if (len == 3 && name[1] == 'I' && name[2] == 'G')
1986                 goto yes;
1987             break;
1988             /* Using ${^...} variables is likely to be sufficiently rare that
1989                it seems sensible to avoid the space hit of also checking the
1990                length.  */
1991         case '\017':   /* ${^OPEN} */
1992             if (strEQ(name1, "PEN"))
1993                 goto yes;
1994             break;
1995         case '\024':   /* ${^TAINT} */
1996             if (strEQ(name1, "AINT"))
1997                 goto yes;
1998             break;
1999         case '\025':    /* ${^UNICODE} */
2000             if (strEQ(name1, "NICODE"))
2001                 goto yes;
2002             if (strEQ(name1, "TF8LOCALE"))
2003                 goto yes;
2004             break;
2005         case '\027':   /* ${^WARNING_BITS} */
2006             if (strEQ(name1, "ARNING_BITS"))
2007                 goto yes;
2008             break;
2009         case '1':
2010         case '2':
2011         case '3':
2012         case '4':
2013         case '5':
2014         case '6':
2015         case '7':
2016         case '8':
2017         case '9':
2018         {
2019             const char *end = name + len;
2020             while (--end > name) {
2021                 if (!isDIGIT(*end))
2022                     return FALSE;
2023             }
2024             goto yes;
2025         }
2026         }
2027     } else {
2028         /* Because we're already assuming that name is NUL terminated
2029            below, we can treat an empty name as "\0"  */
2030         switch (*name) {
2031         case '&':
2032         case '`':
2033         case '\'':
2034         case ':':
2035         case '?':
2036         case '!':
2037         case '-':
2038         case '#':
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 '\001':   /* $^A */
2057         case '\003':   /* $^C */
2058         case '\004':   /* $^D */
2059         case '\005':   /* $^E */
2060         case '\006':   /* $^F */
2061         case '\010':   /* $^H */
2062         case '\011':   /* $^I, NOT \t in EBCDIC */
2063         case '\014':   /* $^L */
2064         case '\016':   /* $^N */
2065         case '\017':   /* $^O */
2066         case '\020':   /* $^P */
2067         case '\023':   /* $^S */
2068         case '\024':   /* $^T */
2069         case '\026':   /* $^V */
2070         case '\027':   /* $^W */
2071         case '1':
2072         case '2':
2073         case '3':
2074         case '4':
2075         case '5':
2076         case '6':
2077         case '7':
2078         case '8':
2079         case '9':
2080         yes:
2081             return TRUE;
2082         default:
2083             break;
2084         }
2085     }
2086     return FALSE;
2087 }
2088
2089 /*
2090  * Local variables:
2091  * c-indentation-style: bsd
2092  * c-basic-offset: 4
2093  * indent-tabs-mode: t
2094  * End:
2095  *
2096  * ex: set ts=8 sts=4 sw=4 noet:
2097  */