gv.c

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